12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513 |
- MODULE WMProperties; (** AUTHOR "TF"; PURPOSE "Properties" *)
- IMPORT
- WMRectangles, WMGraphics, Strings, Localization, Repositories, WMEvents, Locks, XML, XMLObjects, Streams, Commands, Modules, KernelLog, Models, Types;
- TYPE
- String = Strings.String;
- Property* = OBJECT
- VAR
- name, info : String;
- prototype : Property;
- nonDefault : BOOLEAN;
- list : PropertyList; (* contains the list, the property is added to *)
- timestamp : LONGINT; (* incremented when property state is changed; *)
- repository: Repositories.Repository;
- object : Repositories.Component;
- repositoryName : Strings.String;
- componentName : Strings.String;
- generator : Strings.String;
- componentID : LONGINT;
- inLinkUpdate: BOOLEAN;
- PROCEDURE &New*(prototype : Property; name, info : String);
- BEGIN
- SELF.name := name;
- SELF.info := info;
- SELF.prototype := prototype;
- nonDefault := FALSE;
- list := NIL;
- timestamp := 0;
- END New;
- PROCEDURE ReplaceLink*(object: Repositories.Component);
- BEGIN
- IF SELF.object # object THEN
- IF (SELF.object # NIL) THEN SELF.object.onChanged.Remove(LinkChanged) END;
- SELF.object := object;
- IF object # NIL THEN object.onChanged.Add(LinkChanged); LinkChanged(SELF, object) END;
- END;
- END ReplaceLink;
- PROCEDURE LinkChanged(sender, object: ANY);
- BEGIN
- AcquireWrite;
- inLinkUpdate := TRUE;
- UpdateProperty;
- inLinkUpdate := FALSE;
- ReleaseWrite;
- END LinkChanged;
- PROCEDURE SetLinkAsString*(CONST string : ARRAY OF CHAR);
- VAR repositoryName : ARRAY 256 OF CHAR; componentName : ARRAY 128 OF CHAR; componentID : LONGINT;
- context : Repositories.Context; res : WORD; object: Repositories.Component;
- BEGIN
- IF Repositories.IsCommandString(string) THEN
- AcquireWrite;
- SELF.repositoryName := NIL;
- SELF.componentName := NIL;
- SELF.componentID := 0;
- SELF.generator := Strings.NewString(string);
- ReplaceLink(NIL);
- NotDefault;
- Changed;
- ReleaseWrite;
- ELSIF Repositories.SplitName(string, repositoryName, componentName, componentID) THEN
- AcquireWrite;
- IF repositoryName # "" THEN
- SELF.repositoryName := Strings.NewString(repositoryName);
- ELSE (*ASSERT(repository # NIL);*)
- END;
- SELF.componentName := Strings.NewString(componentName);
- SELF.componentID := componentID;
- SELF.generator := NIL;
- ReplaceLink(NIL); (* invalidate reference *)
- NotDefault;
- Changed;
- ReleaseWrite;
- ELSE
- Reset;
- END;
- END SetLinkAsString;
- PROCEDURE GetLinkAsString*(VAR string : ARRAY OF CHAR);
- VAR nbrStr : ARRAY 16 OF CHAR;
- BEGIN
- AcquireRead;
- IF (SELF.generator # NIL) THEN
- COPY(SELF.generator^, string);
- ELSIF (repositoryName # NIL) & (componentName # NIL) THEN
- COPY(repositoryName^, string); Strings.Append(string, Repositories.Delimiter);
- Strings.Append(string, componentName^); Strings.Append(string, Repositories.Delimiter);
- Strings.IntToStr(componentID, nbrStr); Strings.Append(string, nbrStr);
- ELSE
- string := "";
- END;
- ReleaseRead;
- END GetLinkAsString;
- PROCEDURE IsLink(p: ANY): BOOLEAN;
- VAR s:Strings.String; xml: XML.Element; en:XMLObjects.Enumerator;
- BEGIN
- IF (p IS XML.Element) THEN
- xml := p(XML.Element);
- s := xml.GetName();
- IF s # NIL THEN
- IF s^ = "Object" THEN
- en := xml.GetContents();
- p := en.GetNext();
- NotDefault;
- IF (p # NIL ) & (p IS XML.Chars) THEN
- s := p(XML.Chars).GetStr();
- IF s # NIL THEN
- Strings.Trim(s^, " ");
- SetLinkAsString(s^);
- object := GetLink();
- RETURN TRUE
- END
- ELSIF (p # NIL) & (p IS XML.Element) THEN
- ReplaceLink( Repositories.ComponentFromXML(p(XML.Element)));
- object := GetLink();
- RETURN TRUE
- END
- END;
- END;
- END;
- RETURN FALSE
- END IsLink;
- PROCEDURE WriteLink*(w : Streams.Writer; context: ANY; indent : LONGINT): BOOLEAN;
- VAR name : String; id: LONGINT; res: WORD; repository: Repositories.Repository; objectName: String;
- BEGIN
- IF object # NIL THEN
- Indent(w, indent);
- (*level := indent+1;*)
- w.Char("<"); w.String("Object"); w.Char(">");
- IF (context # NIL) & (context IS Repositories.StoreContext) THEN
- repository := context(Repositories.StoreContext).repository;
- id := 1;
- objectName := object.GetName();
- IF (objectName=NIL) OR (objectName^="") THEN objectName :=anonymous END;
- repository.PutComponent(object, objectName^,id,res);
- w.String(":"); (* <-- THIS repository *) w.String(objectName^); w.String(":"); w.Int(id, 0);
- ELSE
- ToStream(w);
- END;
- w.String("</"); w.String("Object"); w.Char(">"); w.Ln;
- RETURN TRUE
- END;
- RETURN FALSE;
- END WriteLink;
- PROCEDURE UpdateModel;
- BEGIN
- END UpdateModel;
- PROCEDURE UpdateProperty;
- BEGIN
- END UpdateProperty;
- PROCEDURE SetLink*(object : Repositories.Component);
- BEGIN
- AcquireWrite; (* TBD: Store object to repository *)
- IF (SELF.object # object) THEN ReplaceLink(object); Changed
- ELSIF ~ nonDefault THEN Changed END;
- NotDefault;
- ReleaseWrite;
- END SetLink;
- PROCEDURE GetLink*() : Repositories.Component;
- VAR object : Repositories.Component; context : Repositories.Context; res : WORD;
- BEGIN
- AcquireRead;
- object := SELF.object;
- ReleaseRead;
- (* late time generation of object for supporting of loading repositories *)
- IF (object = NIL) THEN
- IF (generator # NIL) THEN
- Repositories.CallCommand(generator^, context, res);
- IF (res = Repositories.Ok) & (context.object # NIL) & (context.object IS Repositories.Component) THEN
- object := context.object(Repositories.Component);
- SetLink(object)
- END;
- ELSIF (repositoryName # NIL) & (componentName # NIL) THEN
- Repositories.GetComponent(repositoryName^, componentName^, componentID, object, res);
- SetLink(object);
- ELSIF (componentName # NIL) & (repository # NIL) THEN
- object := repository.GetComponent(componentName^, componentID);
- SetLink(object);
- END;
- END;
- RETURN object
- END GetLink;
- PROCEDURE SetPrototype*(prototype : Property);
- BEGIN
- SELF.prototype := prototype;
- Stamp;
- END SetPrototype;
- PROCEDURE HasPrototype*() : BOOLEAN;
- BEGIN
- RETURN prototype # NIL
- END HasPrototype;
- (** Meta-data *)
- PROCEDURE GetInfo*() : String;
- BEGIN
- IF info # NIL THEN RETURN info
- ELSIF prototype # NIL THEN RETURN prototype.GetInfo()
- ELSE RETURN NIL
- END
- END GetInfo;
- PROCEDURE GetName*() : String;
- BEGIN
- IF name # NIL THEN RETURN name
- ELSIF prototype # NIL THEN RETURN prototype.GetName()
- ELSE RETURN NIL
- END
- END GetName;
- PROCEDURE Stamp*;
- BEGIN (* need protection? *)
- INC(timestamp)
- END Stamp;
-
- PROCEDURE GetTimestamp*() : LONGINT;
- BEGIN
- RETURN timestamp;
- END GetTimestamp;
- PROCEDURE Reset*;
- BEGIN
- AcquireWrite;
- IF nonDefault THEN nonDefault := FALSE; Changed END;
- ReleaseWrite
- END Reset;
- PROCEDURE Changed*; (** PROTECTED *)
- BEGIN
- IF list # NIL THEN list.Changed(SELF) END;
- Stamp;
- END Changed;
- PROCEDURE AcquireWrite*;
- BEGIN
- IF list # NIL THEN list.AcquireWrite END
- END AcquireWrite;
- PROCEDURE ReleaseWrite*;
- BEGIN
- IF list # NIL THEN list.ReleaseWrite END
- END ReleaseWrite;
- PROCEDURE AcquireRead*;
- BEGIN
- IF list # NIL THEN list.AcquireRead END
- END AcquireRead;
- PROCEDURE ReleaseRead*;
- BEGIN
- IF list # NIL THEN list.ReleaseRead END
- END ReleaseRead;
- PROCEDURE NotDefault*; (** PROTECTED *)
- BEGIN
- IF (nonDefault = FALSE) THEN
- nonDefault := TRUE;
- Stamp;
- END;
- END NotDefault;
- PROCEDURE GetIsDefault*() : BOOLEAN;
- BEGIN
- RETURN ~nonDefault
- END GetIsDefault;
- PROCEDURE FromStream*(r : Streams.Reader); (** ABSTRACT *)
- END FromStream;
- PROCEDURE ToStream*(w : Streams.Writer); (** ABSTRACT *)
- END ToStream;
- PROCEDURE FromXML*(xml : XML.Element);
- END FromXML;
- PROCEDURE ToXML*(VAR element: XML.Element);
- VAR name: String;
- BEGIN
- name := GetName();
- NEW(element); IF name # NIL THEN element.SetName(name^); END;
- END ToXML;
- PROCEDURE WriteXML*(w : Streams.Writer; context: ANY; indent : LONGINT);
- END WriteXML;
- PROCEDURE Finalize*;
- BEGIN
- END Finalize;
- END Property;
- TYPE
- BooleanProperty* = OBJECT(Property)
- VAR
- value : BOOLEAN;
- PROCEDURE FromStream*(r : Streams.Reader);
- VAR token : ARRAY 5 OF CHAR; v : BOOLEAN;
- BEGIN
- AcquireWrite;
- NotDefault;
- r.Token(token); Strings.UpperCase(token); v := token = "TRUE";
- IF v # value THEN value := v; Changed END;
- ReleaseWrite
- END FromStream;
- PROCEDURE ToStream*(w : Streams.Writer);
- BEGIN
- AcquireRead;
- IF Get() THEN w.String("true") ELSE w.String("false") END;
- ReleaseRead
- END ToStream;
- PROCEDURE UpdateProperty;
- VAR boolean: Types.Boolean; model: Models.Model; res: WORD;
- BEGIN
- IF GetModel(object, model) THEN
- model.GetGeneric(boolean, res);
- IF res = 0 THEN Set(boolean.value) END;
- END;
- END UpdateProperty;
- PROCEDURE UpdateModel;
- VAR type: Types.Boolean; model: Models.Model; res: WORD;
- BEGIN
- IF inLinkUpdate THEN RETURN END;
- IF GetModel(object, model) THEN
- type.value := value;
- model.SetGeneric(type, res);
- END;
- END UpdateModel;
- PROCEDURE Get*() : BOOLEAN;
- VAR r : BOOLEAN;
- BEGIN
- AcquireRead;
- IF nonDefault OR (prototype = NIL) THEN r := value
- ELSE r := prototype(BooleanProperty).Get()
- END;
- ReleaseRead;
- RETURN r
- END Get;
- PROCEDURE Set*(value : BOOLEAN);
- BEGIN
- AcquireWrite;
- IF value # SELF.value THEN SELF.value := value; Changed;
- IF (object # NIL) THEN UpdateModel END;
- ELSIF ~ nonDefault THEN Changed END;
- NotDefault;
- ReleaseWrite;
- END Set;
- (* set without updates -- use only when you definitely want to avoid updates *)
- PROCEDURE SetPassive*(value : BOOLEAN);
- BEGIN
- AcquireWrite;
- SELF.value := value;
- NotDefault;
- ReleaseWrite
- END SetPassive;
- PROCEDURE FromXML*(xml : XML.Element);
- VAR en : XMLObjects.Enumerator; p : ANY; s : String;
- BEGIN
- en := xml.GetContents();
- p := en.GetNext();
- value := FALSE; NotDefault;
- IF IsLink(p) THEN
- ELSIF p IS XML.Chars THEN
- s := p(XML.Chars).GetStr();
- IF s # NIL THEN
- Strings.Trim(s^, " "); Strings.LowerCase(s^);
- Set(s^ = "true")
- END
- END;
- END FromXML;
- PROCEDURE ToXML*(VAR element: XML.Element);
- VAR chars: XML.ArrayChars; s: String;
- BEGIN
- IF (GetName # NIL) & nonDefault THEN
- ToXML^(element);
- element.SetAttributeValue("loader","WMProperties.NewBoolean");
- NEW(chars); element.AddContent(chars);
- IF Get() THEN chars.SetStr("true") ELSE chars.SetStr("false") END;
- s := GetName();
- END;
- END ToXML;
- PROCEDURE WriteXML*(w : Streams.Writer; context: ANY; indent : LONGINT);
- VAR name : String;
- BEGIN
- name := GetName();
- IF name = NIL THEN KernelLog.String("Nameless boolean property encountered. Ignored"); KernelLog.Ln; RETURN END;
- IF nonDefault THEN
- Indent(w, indent);
- w.Char("<"); w.String(name^); w.String(' loader="WMProperties.NewBoolean"'); w.Char(">");
- IF ~WriteLink(w,context,indent) THEN
- IF value THEN w.String("true") ELSE w.String("false") END;
- END;
- w.String("</"); w.String(name^); w.Char(">"); w.Ln;
- END
- END WriteXML;
- END BooleanProperty;
- TYPE
- SetProperty* = OBJECT(Property)
- VAR
- value : SET;
- PROCEDURE IntToSet(h:LONGINT):SET;
- VAR i:LONGINT; set:SET;
- BEGIN
- i:=0;
- WHILE h#0 DO
- IF h MOD 2=1 THEN INCL(set,i) END;
- h:=h DIV 2;
- INC(i);
- END;
- RETURN set;
- END IntToSet;
- PROCEDURE SetToInt(set:SET):HUGEINT;
- VAR i:LONGINT; int:HUGEINT; s: String;
- BEGIN
- NEW(s, 18);
- FOR i:=31 TO 0 BY -1 DO
- int:=int * 2;
- IF i IN set THEN INC(int) END;
- END;
- RETURN int
- END SetToInt;
- PROCEDURE FromStream*(r : Streams.Reader);
- VAR token : ARRAY 10 OF CHAR; v : SET; i:LONGINT; res: WORD;
- BEGIN
- AcquireWrite;
- NotDefault;
- r.String(token); Strings.HexStrToInt(token,i,res);
- IF res=Strings.Ok THEN
- v:=IntToSet(i);
- IF v # value THEN value := v; Changed END;
- END;
- ReleaseWrite
- END FromStream;
- (*! to discuss: should a SET be written explicitely ? readability vs overhead*)
- PROCEDURE ToStream*(w : Streams.Writer);
- VAR s:ARRAY 10 OF CHAR;
- BEGIN
- AcquireRead;
- Strings.IntToHexStr(SetToInt(Get()),8,s);
- Strings.AppendChar(s,"H");
- w.String(s);
- ReleaseRead
- END ToStream;
- PROCEDURE UpdateProperty;
- VAR boolean: Types.Set; model: Models.Model; res: WORD;
- BEGIN
- IF GetModel(object, model) THEN
- model.GetGeneric(boolean, res);
- IF res = 0 THEN Set(boolean.value) END;
- END;
- END UpdateProperty;
- PROCEDURE UpdateModel;
- VAR type: Types.Set; model: Models.Model; res: WORD;
- BEGIN
- IF inLinkUpdate THEN RETURN END;
- IF GetModel(object, model) THEN
- type.value := value;
- model.SetGeneric(type, res);
- END;
- END UpdateModel;
- PROCEDURE Get*() : SET;
- VAR r : SET;
- BEGIN
- AcquireRead;
- IF nonDefault OR (prototype = NIL) THEN r := value
- ELSE r := prototype(SetProperty).Get()
- END;
- ReleaseRead;
- RETURN r
- END Get;
- PROCEDURE Set*(value : SET);
- BEGIN
- AcquireWrite;
- IF value # SELF.value THEN
- SELF.value := value;
- IF (object # NIL) THEN UpdateModel END;
- Changed
- ELSIF ~ nonDefault THEN Changed END;
- NotDefault;
- ReleaseWrite;
- END Set;
- (* set without updates -- use only when you definitely want to avoid updates *)
- PROCEDURE SetPassive*(value : SET);
- BEGIN
- AcquireWrite;
- SELF.value := value;
- NotDefault;
- ReleaseWrite
- END SetPassive;
- (*! to discuss: should a SET be written explicitely - readability at cost of overhead*)
- PROCEDURE FromXML*(xml : XML.Element);
- VAR en : XMLObjects.Enumerator; p : ANY; s : String; i:LONGINT;
- BEGIN
- en := xml.GetContents();
- p := en.GetNext();
- NotDefault;
- IF IsLink(p) THEN
- ELSIF p IS XML.Chars THEN
- s := p(XML.Chars).GetStr();
- IF s # NIL THEN
- Strings.Trim(s^, " ");
- Strings.StrToInt(s^,i);
- Set(IntToSet(i))
- END
- END
- END FromXML;
- PROCEDURE ToXML*(VAR element: XML.Element);
- VAR chars: XML.ArrayChars;s: ARRAY 10 OF CHAR;
- BEGIN
- IF (GetName # NIL) & nonDefault THEN
- ToXML^(element);
- element.SetAttributeValue("loader","WMProperties.NewSet");
- NEW(chars); element.AddContent(chars);
- Strings.IntToHexStr(SetToInt(value),8,s); Strings.AppendChar(s,"H");
- chars.SetStr(s);
- END;
- END ToXML;
- PROCEDURE WriteXML*(w : Streams.Writer; context: ANY; indent : LONGINT);
- VAR name : String; s: ARRAY 10 OF CHAR;
- BEGIN
- name := GetName();
- IF name = NIL THEN KernelLog.String("Nameless boolean property encountered. Ignored"); KernelLog.Ln; RETURN END;
- IF nonDefault THEN
- Indent(w, indent);
- w.Char("<"); w.String(name^); w.String(' loader="WMProperties.NewSet"'); w.Char(">");
- IF ~WriteLink(w,context,indent) THEN
- Strings.IntToHexStr(SetToInt(value),8,s); Strings.AppendChar(s,"H");
- w.String(s);
- END;
- w.String("</"); w.String(name^); w.Char(">"); w.Ln;
- END
- END WriteXML;
- END SetProperty;
- TYPE
- (** Accessor property to an integer value. The range of possible values can be restricted. *)
- Int32Property* = OBJECT(Property)
- VAR
- value : LONGINT;
- min, max : LONGINT;
- bounded : BOOLEAN;
- PROCEDURE UpdateProperty;
- VAR integer: Types.Integer; model: Models.Model; res: WORD;
- BEGIN
- IF GetModel(object, model) THEN
- model.GetGeneric(integer, res);
- IF res = 0 THEN Set(integer.value) END;
- END;
- END UpdateProperty;
- PROCEDURE UpdateModel;
- VAR type: Types.Integer; model: Models.Model; res: WORD;
- BEGIN
- IF inLinkUpdate THEN RETURN END;
- IF GetModel(object, model) THEN
- type.value := value;
- model.SetGeneric(type, res);
- END;
- END UpdateModel;
- (** Confines the possible input values between min and max. Implicitly activates the bounds check. If the current value
- lies outside the bounds, it is truncated to the nearest and a change notification is sent after the end of the transaction. *)
- PROCEDURE SetBounds*(min, max : LONGINT);
- BEGIN
- AcquireWrite;
- SELF.min := min; SELF.max := max; bounded := TRUE;
- Stamp;
- Set(value);
- ReleaseWrite
- END SetBounds;
- PROCEDURE GetBounds*(VAR min, max : LONGINT);
- BEGIN
- AcquireRead;
- min := SELF.min; max := SELF.max;
- ReleaseRead;
- END GetBounds;
- (** enables or disables the bounds of the value. If enabled, a change notification is sent if the current value had to be
- changed to lie within the bounds *)
- PROCEDURE SetIsBounded*(isBounded : BOOLEAN);
- BEGIN
- AcquireWrite;
- IF isBounded # bounded THEN
- bounded := isBounded;
- Stamp;
- Set(value);
- END;
- ReleaseWrite
- END SetIsBounded;
- PROCEDURE GetIsBounded*(VAR isBounded : BOOLEAN);
- BEGIN
- AcquireRead;
- isBounded := bounded;
- ReleaseRead;
- END GetIsBounded;
- PROCEDURE Validate(v : LONGINT) : LONGINT;
- BEGIN
- IF bounded THEN RETURN MAX(min, MIN(max, v))
- ELSE RETURN v
- END
- END Validate;
- PROCEDURE FromStream*(r : Streams.Reader);
- VAR v : LONGINT;
- BEGIN
- AcquireWrite;
- r.Int(v, TRUE);
- Set(v);
- ReleaseWrite
- END FromStream;
- PROCEDURE ToStream*(w : Streams.Writer);
- BEGIN
- AcquireRead;
- w.Int(value, 0);
- ReleaseRead
- END ToStream;
- PROCEDURE Get*() : LONGINT;
- VAR r : LONGINT;
- BEGIN
- AcquireRead;
- IF nonDefault OR (prototype = NIL) THEN r := value
- ELSE r := prototype(Int32Property).Get()
- END;
- ReleaseRead;
- RETURN r
- END Get;
- PROCEDURE Set*(value : LONGINT);
- VAR v: LONGINT;
- BEGIN
- v := Validate(value);
- AcquireWrite;
- IF v # SELF.value THEN
- SELF.value := v;
- Changed;
- IF object # NIL THEN UpdateModel END;
- ELSIF ~nonDefault THEN
- Changed;
- END;
- NotDefault;
- ReleaseWrite
- END Set;
- (* set without updates -- use only when you definitely want to avoid updates *)
- PROCEDURE SetPassive*(value : LONGINT);
- VAR v: LONGINT;
- BEGIN
- v := Validate(value);
- AcquireWrite;
- SELF.value := v;
- NotDefault;
- ReleaseWrite
- END SetPassive;
- PROCEDURE FromXML*(xml : XML.Element);
- VAR
- en : XMLObjects.Enumerator;
- p : ANY;
- s, mins, maxs : String;
- BEGIN
- AcquireWrite; NotDefault;
- mins := xml.GetAttributeValue("min");
- maxs := xml.GetAttributeValue("max");
- IF mins # NIL THEN Strings.StrToInt(mins^, min) ELSE min := MIN(LONGINT) END;
- IF maxs # NIL THEN Strings.StrToInt(maxs^, max) ELSE max := MAX(LONGINT) END;
- bounded := (mins # NIL) OR (maxs # NIL);
- en := xml.GetContents();
- IF en.HasMoreElements() THEN
- p := en.GetNext();
- IF IsLink(p) THEN
- ELSIF p IS XML.Chars THEN
- s := p(XML.Chars).GetStr();
- IF s # NIL THEN Strings.StrToInt(s^, value); Set(value) END
- END
- END;
- Stamp;
- ReleaseWrite
- END FromXML;
- PROCEDURE ToXML*(VAR element: XML.Element);
- VAR chars: XML.ArrayChars;s: ARRAY 20 OF CHAR;
- BEGIN
- IF (GetName # NIL) & nonDefault THEN
- ToXML^(element);
- element.SetAttributeValue("loader","WMProperties.NewInt32");
- element.AddContent(NewIntChars(value));
- END;
- END ToXML;
- PROCEDURE WriteXML*(w : Streams.Writer; context: ANY; indent : LONGINT);
- VAR name : String;
- BEGIN
- name := GetName();
- IF name = NIL THEN KernelLog.String("Nameless Int32 property encountered. Ignored"); KernelLog.Ln; RETURN END;
- IF nonDefault THEN
- Indent(w, indent);
- w.Char("<"); w.String(name^); w.String(' loader="WMProperties.NewInt32"'); w.Char(">");
- IF ~WriteLink(w,context,indent) THEN
- w.Int(value, 0);
- END;
- w.String("</"); w.String(name^); w.Char(">"); w.Ln
- END
- END WriteXML;
- END Int32Property;
- TYPE
- (** Accessor property to an real value. The range of possible values can be restricted. *)
- RealProperty* = OBJECT(Property)
- VAR
- value : LONGREAL;
- min, max : LONGREAL;
- bounded : BOOLEAN;
- (** Confines the possible input values between min and max. Implicitly activates the bounds check. If the current value
- lies outside the bounds, it is truncated to the nearest and a change notification is sent after the end of the transaction. *)
- PROCEDURE SetBounds*(min, max : LONGREAL);
- BEGIN
- AcquireWrite;
- SELF.min := min; SELF.max := max; bounded := TRUE;
- Stamp;
- Set(value);
- ReleaseWrite
- END SetBounds;
- PROCEDURE GetBounds*(VAR min, max : LONGREAL);
- BEGIN
- AcquireRead;
- min := SELF.min; max := SELF.max;
- ReleaseRead;
- END GetBounds;
- (** enables or disables the bounds of the value. If enabled, a change notification is sent if the current value had to be
- changed to lie within the bounds *)
- PROCEDURE SetIsBounded*(isBounded : BOOLEAN);
- BEGIN
- AcquireWrite;
- IF isBounded # bounded THEN
- bounded := isBounded;
- Stamp;
- Set(value);
- END;
- ReleaseWrite
- END SetIsBounded;
- PROCEDURE GetIsBounded*(VAR isBounded : BOOLEAN);
- BEGIN
- AcquireRead;
- isBounded := bounded;
- ReleaseRead;
- END GetIsBounded;
- PROCEDURE Validate(v : LONGREAL) : LONGREAL;
- VAR result : LONGREAL;
- BEGIN
- result := v;
- IF bounded THEN
- IF (result < min) THEN result := min; ELSIF (result > max) THEN result := max; END;
- END;
- RETURN result;
- END Validate;
- PROCEDURE FromStream*(r : Streams.Reader);
- VAR temp : ARRAY 64 OF CHAR; value : LONGREAL;
- BEGIN
- r.String(temp);
- value := 0.0;
- Strings.StrToFloat(temp, value);
- Set(value);
- END FromStream;
- PROCEDURE ToStream*(w : Streams.Writer);
- BEGIN
- AcquireRead;
- w.Float(value, 24);
- ReleaseRead
- END ToStream;
- PROCEDURE UpdateProperty;
- VAR longreal: Types.Longreal; model: Models.Model; res: WORD; silent: BOOLEAN;
- BEGIN
- IF GetModel(object, model) THEN
- model.GetGeneric(longreal, res);
- IF res = 0 THEN Set(longreal.value) END;
- END;
- END UpdateProperty;
- PROCEDURE UpdateModel;
- VAR type: Types.Longreal; model: Models.Model; res: WORD;
- BEGIN
- IF inLinkUpdate THEN RETURN END;
- IF GetModel(object, model) THEN
- type.value := value;
- model.SetGeneric(type, res);
- END;
- END UpdateModel;
- PROCEDURE Get*() : LONGREAL;
- VAR r : LONGREAL;
- BEGIN
- AcquireRead;
- IF nonDefault OR (prototype = NIL) THEN r := value;
- ELSE r := prototype(RealProperty).Get();
- END;
- ReleaseRead;
- RETURN r
- END Get;
- PROCEDURE Set*(value : LONGREAL);
- VAR v: LONGREAL;
- BEGIN
- v := Validate(value);
- AcquireWrite;
- IF v # SELF.value THEN
- SELF.value := v;
- Changed;
- IF object # NIL THEN UpdateModel END;
- ELSIF ~nonDefault THEN
- Changed;
- END;
- NotDefault;
- ReleaseWrite
- END Set;
- (* set without updates -- use only when you definitely want to avoid updates *)
- PROCEDURE SetPassive*(value : LONGREAL);
- VAR v: LONGREAL;
- BEGIN
- v := Validate(value);
- AcquireWrite;
- SELF.value := v;
- NotDefault;
- ReleaseWrite
- END SetPassive;
- PROCEDURE FromXML*(xml : XML.Element);
- VAR
- en : XMLObjects.Enumerator;
- p : ANY;
- s, mins, maxs : String;
- BEGIN
- AcquireWrite; NotDefault;
- mins := xml.GetAttributeValue("min");
- maxs := xml.GetAttributeValue("max");
- IF mins # NIL THEN Strings.StrToFloat(mins^, min) ELSE min := MIN(LONGREAL) END;
- IF maxs # NIL THEN Strings.StrToFloat(maxs^, max) ELSE max := MAX(LONGREAL) END;
- bounded := (mins # NIL) OR (maxs # NIL);
- en := xml.GetContents();
- IF en.HasMoreElements() THEN
- p := en.GetNext();
- IF IsLink(p) THEN
- ELSIF p IS XML.Chars THEN
- s := p(XML.Chars).GetStr();
- IF s # NIL THEN Strings.StrToFloat(s^, value); Set(value) END
- END
- END;
- Stamp;
- ReleaseWrite
- END FromXML;
- PROCEDURE ToXML*(VAR element: XML.Element);
- VAR chars: XML.ArrayChars;s: ARRAY 20 OF CHAR; w: Streams.StringWriter;
- BEGIN
- IF (GetName # NIL) & nonDefault THEN
- ToXML^(element);
- element.SetAttributeValue("loader","WMProperties.NewReal");
- NEW(chars); element.AddContent(chars);
- NEW(w,30); w.Float(value,24); w.Get(s);
- chars.SetStr(s);
- END;
- END ToXML;
- PROCEDURE WriteXML*(w : Streams.Writer; context: ANY; indent : LONGINT);
- VAR name : String;
- BEGIN
- name := GetName();
- IF name = NIL THEN KernelLog.String("Nameless Real property encountered. Ignored"); KernelLog.Ln; RETURN END;
- IF nonDefault THEN
- Indent(w, indent);
- w.Char("<"); w.String(name^); w.String(' loader="WMProperties.NewReal"'); w.Char(">");
- IF ~WriteLink(w,context,indent) THEN
- w.Float(value, 24);
- END;
- w.String("</"); w.String(name^); w.Char(">"); w.Ln
- END
- END WriteXML;
- END RealProperty;
- TYPE
- StringProperty* = OBJECT(Property)
- VAR
- value, word : String;
- dictionary : Repositories.Dictionary;
- languages : Localization.Languages;
- translate : BOOLEAN;
- PROCEDURE &New*(prototype : Property; name, info : String);
- BEGIN
- New^(prototype, name, info);
- value := NIL; word := NIL;
- dictionary := NIL;
- languages := Localization.GetLanguagePreferences();
- translate := TRUE;
- END New;
- PROCEDURE SetTranslate*(translate : BOOLEAN);
- BEGIN
- AcquireWrite;
- IF (SELF.translate # translate) THEN
- SELF.translate := translate;
- IF ~translate THEN
- dictionary := NIL; word := NIL;
- ELSE
- Translate;
- END;
- NotDefault;
- Changed;
- END;
- ReleaseWrite;
- END SetTranslate;
- PROCEDURE Translate;
- VAR res : WORD; temp : Strings.String;
- BEGIN (* caller holds lock *)
- IF translate & (SELF.value # NIL) THEN
- Repositories.GetTranslationInfo(SELF.value^, dictionary, word, res);
- IF (dictionary # NIL) & (word # NIL) THEN
- temp := dictionary.Translate(word, languages);
- IF (temp # word) THEN
- value := temp;
- END;
- END;
- END;
- END Translate;
- PROCEDURE SetLanguage*(languages : Localization.Languages);
- BEGIN
- AcquireWrite;
- SELF.languages := languages;
- IF (dictionary # NIL) & (word # NIL) THEN
- value := dictionary.Translate(word, languages);
- NotDefault;
- Changed;
- END;
- ReleaseWrite;
- END SetLanguage;
- PROCEDURE FromStream*(r : Streams.Reader);
- VAR buffer : ARRAY 1024 OF CHAR; res : WORD;
- BEGIN
- AcquireWrite;
- XML.UTF8FromStream(buffer, r, res);
- value := Strings.NewString(buffer); Translate; NotDefault; Changed;
- ReleaseWrite
- END FromStream;
- PROCEDURE ToStream*(w : Streams.Writer);
- BEGIN
- AcquireRead;
- IF (dictionary # NIL) & (word # NIL) THEN
- w.String("::"); w.String(dictionary.fullname^); w.String(":"); w.String(word^);
- ELSIF value # NIL THEN
- w.String(value^);
- END;
- ReleaseRead
- END ToStream;
- PROCEDURE Get*() : String;
- VAR r : String;
- BEGIN
- AcquireRead;
- IF nonDefault OR (prototype = NIL) THEN r := value
- ELSE r := prototype(StringProperty).Get()
- END;
- ReleaseRead;
- RETURN r
- END Get;
- PROCEDURE UpdateModel;
- VAR type: Types.String; model: Models.Model; res: WORD;
- BEGIN
- IF inLinkUpdate THEN RETURN END;
- IF GetModel(object, model) THEN
- type.value := value;
- model.SetGeneric(type, res);
- END;
- END UpdateModel;
- PROCEDURE Set*(value : String);
- BEGIN
- AcquireWrite;
- IF (value = SELF.value) (* reset with self must lead to update *) OR (value = NIL) OR (SELF.value = NIL) OR (value^ # SELF.value^) THEN
- SELF.value := value; Translate;Changed;
- IF (object # NIL) THEN UpdateModel END;
- ELSIF ~nonDefault THEN
- Changed
- END;
- NotDefault;
- ReleaseWrite
- END Set;
- (* set without updates -- use only when you definitely want to avoid updates *)
- PROCEDURE SetPassive*(value : String);
- BEGIN
- AcquireWrite;
- IF (value # NIL) & (SELF.value # NIL) & (value^ # SELF.value^) THEN
- SELF.value := value; Translate;
- ELSE
- SELF.value := value;
- END;
- NotDefault;
- ReleaseWrite
- END SetPassive;
- PROCEDURE UpdateProperty;
- VAR type: Types.String; model: Models.Model; res: WORD;
- BEGIN
- IF GetModel(object, model) THEN
- type.value := value; (* pass pointer to string *)
- model.GetGeneric(type, res);
- IF res = 0 THEN Set(type.value) END;
- END;
- END UpdateProperty;
- PROCEDURE GetAOC*(VAR value : ARRAY OF CHAR);
- BEGIN
- value := "";
- AcquireRead;
- IF (SELF.value # NIL) THEN
- COPY(SELF.value^, value);
- END;
- ReleaseRead;
- END GetAOC;
- PROCEDURE SetAOC*(CONST value : ARRAY OF CHAR);
- BEGIN
- AcquireWrite;
- Strings.SetAOC(value, SELF.value);
- Set(SELF.value);
- ReleaseWrite;
- END SetAOC;
- PROCEDURE FromXML*(xml : XML.Element);
- VAR en : XMLObjects.Enumerator; p : ANY;
- BEGIN
- en := xml.GetContents();
- p := en.GetNext();
- IF p # NIL THEN
- IF IsLink(p) THEN
- ELSIF p IS XML.Chars THEN
- Set(p(XML.Chars).GetStr())
- END
- ELSE
- Set(NIL)
- END
- END FromXML;
- PROCEDURE ToXML*(VAR element: XML.Element);
- VAR chars: XML.ArrayChars;s: String; w: Streams.StringWriter; res: WORD; len: LONGINT;
- BEGIN
- IF (GetName # NIL) & nonDefault THEN
- ToXML^(element);
- element.SetAttributeValue("loader","WMProperties.NewString");
- IF (value # NIL) OR ((dictionary # NIL) & (word # NIL)) THEN
- NEW(chars); element.AddContent(chars);
- len := 64;
- IF (value # NIL) THEN INC(len, LEN(value^)) END;
- NEW(w, len);
- IF (dictionary # NIL) & (word # NIL) THEN
- w.String("::");
- XML.UTF8ToStream(dictionary.fullname^, w, res);
- IF (res = XML.Ok) THEN
- w.String(":");
- XML.UTF8ToStream(word^, w, res);
- END;
- ELSE
- XML.UTF8ToStream(value^, w, res);
- END;
- NEW(s, w.Pos()+1); w.Get(s^);
- chars.SetStr(s^);
- END;
- END;
- END ToXML;
- PROCEDURE WriteXML*(w : Streams.Writer; context: ANY; indent : LONGINT);
- VAR name : String; res : WORD;
- BEGIN
- name := GetName();
- IF name = NIL THEN KernelLog.String("WMProperties: Nameless string property encountered. Ignored "); KernelLog.Ln; RETURN END;
- IF nonDefault THEN
- IF (value # NIL) OR ((dictionary # NIL) & (word # NIL)) THEN
- Indent(w, indent);
- w.Char("<"); w.String(name^); w.String(' loader="WMProperties.NewString"'); w.Char(">");
- IF ~WriteLink(w,context,indent) THEN
- IF (dictionary # NIL) & (word # NIL) THEN
- w.String("::");
- XML.UTF8ToStream(dictionary.fullname^, w, res);
- IF (res = XML.Ok) THEN
- w.String(":");
- XML.UTF8ToStream(word^, w, res);
- END;
- ELSE
- XML.UTF8ToStream(value^, w, res);
- END;
- END;
- w.String("</"); w.String(name^); w.Char(">"); w.Ln;
- IF (res # XML.Ok) THEN
- KernelLog.String("WMProperties.StringProperty.WriteXML: Warning!"); KernelLog.Ln;
- END;
- END;
- END
- END WriteXML;
- END StringProperty;
- TYPE
- ColorProperty* = OBJECT(Property)
- VAR
- value : WMGraphics.Color;
- (* TODO: read hex from CCG FontConverter *)
- PROCEDURE FromStream*(r : Streams.Reader);
- VAR v : LONGINT;
- BEGIN
- AcquireWrite;
- r.Int(v, TRUE); NotDefault;
- IF v # value THEN value := v; Changed END;
- ReleaseWrite
- END FromStream;
- PROCEDURE ToStream*(w : Streams.Writer);
- BEGIN
- AcquireRead;
- w.Hex(value, -8);
- ReleaseRead
- END ToStream;
- PROCEDURE UpdateProperty;
- VAR boolean: Types.Integer; model: Models.Model; res: WORD;
- BEGIN
- IF GetModel(object, model) THEN
- model.GetGeneric(boolean, res);
- IF res = 0 THEN Set(boolean.value) END;
- END;
- END UpdateProperty;
- PROCEDURE UpdateModel;
- VAR type: Types.Integer; model: Models.Model; res: WORD;
- BEGIN
- IF inLinkUpdate THEN RETURN END;
- IF GetModel(object, model) THEN
- type.value := value;
- model.SetGeneric(type, res);
- END;
- END UpdateModel;
- PROCEDURE Get*() : WMGraphics.Color;
- VAR r : WMGraphics.Color;
- BEGIN
- AcquireRead;
- IF nonDefault OR (prototype = NIL) THEN r := value
- ELSE r := prototype(ColorProperty).Get()
- END;
- ReleaseRead;
- RETURN r
- END Get;
- PROCEDURE Set*(value : HUGEINT);
- BEGIN
- AcquireWrite;
- IF SHORT(value) # SELF.value THEN
- SELF.value := SHORT(value); Changed;
- IF (object # NIL) THEN UpdateModel END;
- ELSIF ~nonDefault THEN Changed
- END;
- NotDefault;
- ReleaseWrite
- END Set;
- (* set without updates -- use only when you definitely want to avoid updates *)
- PROCEDURE SetPassive*(value: HUGEINT);
- BEGIN
- AcquireWrite;
- SELF.value := SHORT(value);
- NotDefault;
- ReleaseWrite
- END SetPassive;
- PROCEDURE FromXML*(xml : XML.Element);
- VAR
- en : XMLObjects.Enumerator;
- p : ANY;
- s : String; res : WORD;
- BEGIN
- AcquireWrite;
- en := xml.GetContents();
- IF en.HasMoreElements() THEN
- p := en.GetNext();
- IF IsLink(p) THEN
- ELSIF p IS XML.Chars THEN
- s := p(XML.Chars).GetStr();
- IF s # NIL THEN Strings.HexStrToInt(s^, value, res) END; NotDefault
- END
- END;
- Stamp;
- ReleaseWrite
- END FromXML;
- PROCEDURE ToXML*(VAR element: XML.Element);
- VAR chars: XML.ArrayChars;s: String; w: Streams.StringWriter; res: WORD;
- BEGIN
- IF (GetName # NIL) & nonDefault THEN
- ToXML^(element);
- element.SetAttributeValue("loader","WMProperties.NewColor");
- NEW(chars); element.AddContent(chars);
- NEW(w,10 );
- w.Hex(value, -8);
- NEW(s, w.Pos()+1); w.Get(s^);
- chars.SetStr(s^);
- END;
- END ToXML;
- PROCEDURE WriteXML*(w : Streams.Writer; context: ANY; indent : LONGINT);
- VAR name : String;
- BEGIN
- name := GetName();
- IF name = NIL THEN KernelLog.String("Nameless color property encountered. Ignored"); KernelLog.Ln; RETURN END;
- IF nonDefault THEN
- Indent(w, indent);
- w.Char("<"); w.String(name^); w.String(' loader="WMProperties.NewColor"'); w.Char(">");
- IF ~WriteLink(w,context,indent) THEN
- w.Hex(value, -8);
- END;
- w.String("</"); w.String(name^); w.Char(">"); w.Ln;
- END
- END WriteXML;
- END ColorProperty;
- TYPE
- FontProperty* = OBJECT(Property)
- VAR
- font : WMGraphics.Font; (* { font # NIL } *)
- PROCEDURE &New*(prototype : Property; name, info : String);
- BEGIN
- New^(prototype, name, info);
- font := WMGraphics.GetDefaultFont();
- END New;
- PROCEDURE FromStream*(r : Streams.Reader);
- VAR font : WMGraphics.Font; name, temp : ARRAY 32 OF CHAR; size : LONGINT; style : SET;
- BEGIN
- AcquireWrite;
- NotDefault;
- name := ""; size := 0; style := {};
- IF r.GetString(name) & r.GetInteger(size, FALSE) & r.GetString(temp) THEN
- Strings.StrToSet(temp, style);
- IF size < 6 THEN size := 6 END;
- font := WMGraphics.GetFont(name, size, style);
- IF (font = NIL) THEN font := WMGraphics.GetDefaultFont(); END;
- IF (SELF.font # font) THEN SELF.font := font; Changed END;
- END;
- ReleaseWrite
- END FromStream;
- PROCEDURE ToStream*(w : Streams.Writer);
- VAR font : WMGraphics.Font; temp : ARRAY 32 OF CHAR;
- BEGIN
- AcquireRead;
- font := Get();
- w.String(font.name); w.Char(" "); w.Int(font.size, 0); w.Char(" ");
- Strings.SetToStr(font.style, temp); w.String(temp);
- ReleaseRead
- END ToStream;
- PROCEDURE Get*() : WMGraphics.Font;
- VAR font : WMGraphics.Font;
- BEGIN
- AcquireRead;
- IF nonDefault OR (prototype = NIL) THEN font := SELF.font;
- ELSE font := prototype(FontProperty).Get()
- END;
- ReleaseRead;
- IF (font = NIL) THEN font := WMGraphics.GetDefaultFont(); END;
- ASSERT(font # NIL);
- RETURN font;
- END Get;
- PROCEDURE Set*(font : WMGraphics.Font);
- BEGIN
- IF (font = NIL) THEN font := WMGraphics.GetDefaultFont(); END;
- ASSERT(font # NIL);
- AcquireWrite;
- IF font # SELF.font THEN
- SELF.font := font; Changed;
- IF object # NIL THEN UpdateModel END;
- ELSIF ~ nonDefault THEN Changed END;
- NotDefault;
- ReleaseWrite;
- END Set;
-
- (* set without updates -- use only when you definitely want to avoid updates *)
- PROCEDURE SetPassive*(font: WMGraphics.Font);
- BEGIN
- IF (font = NIL) THEN font := WMGraphics.GetDefaultFont(); END;
- ASSERT(font # NIL);
- AcquireWrite;
- SELF.font := font;
- NotDefault;
- ReleaseWrite
- END SetPassive;
- PROCEDURE GetFont*(VAR name : ARRAY OF CHAR; VAR size : LONGINT; VAR style : SET);
- VAR font : WMGraphics.Font;
- BEGIN
- font := Get();
- COPY(font.name, name); size := font.size; style := font.style;
- END GetFont;
- PROCEDURE SetFont*(CONST name : ARRAY OF CHAR; size : LONGINT; style : SET);
- VAR font : WMGraphics.Font;
- BEGIN
- IF size < 6 THEN size := 6 END;
- font := WMGraphics.GetFont(name, size, style);
- IF (font = NIL) THEN font := WMGraphics.GetDefaultFont(); END;
- ASSERT(font # NIL);
- AcquireWrite;
- IF (SELF.font # font) THEN SELF.font := font; Changed; END;
- NotDefault;
- ReleaseWrite;
- END SetFont;
- PROCEDURE SetFontName*(CONST name : ARRAY OF CHAR);
- VAR font : WMGraphics.Font;
- BEGIN
- AcquireWrite;
- font := Get();
- IF (font.name # name) THEN
- font := WMGraphics.GetFont(name, font.size, font.style);
- IF (font = NIL) THEN font := WMGraphics.GetDefaultFont(); END;
- IF (SELF.font # font) THEN
- SELF.font := font;
- Changed;
- END;
- END;
- NotDefault;
- ReleaseWrite;
- END SetFontName;
- PROCEDURE GetFontName*(VAR name : ARRAY OF CHAR);
- VAR font : WMGraphics.Font;
- BEGIN
- font := Get();
- COPY(font.name, name);
- END GetFontName;
- PROCEDURE SetSize*(size : LONGINT);
- VAR font : WMGraphics.Font;
- BEGIN
- AcquireWrite;
- font := Get();
- IF size < 6 THEN size := 6 END;
- IF (font.size # size) THEN
- font := WMGraphics.GetFont(font.name, size, font.style);
- IF (font = NIL) THEN font := WMGraphics.GetDefaultFont(); END;
- IF (SELF.font # font) THEN
- SELF.font := font;
- Changed;
- END;
- END;
- NotDefault;
- ReleaseWrite;
- END SetSize;
- PROCEDURE GetSize*() : LONGINT;
- VAR font : WMGraphics.Font;
- BEGIN
- font := Get();
- RETURN font.size;
- END GetSize;
- PROCEDURE SetStyle*(style : SET);
- VAR font : WMGraphics.Font;
- BEGIN
- AcquireWrite;
- font := Get();
- IF (font.style # style) THEN
- font := WMGraphics.GetFont(font.name, font.size, style);
- IF (font = NIL) THEN font := WMGraphics.GetDefaultFont(); END;
- IF (SELF.font # font) THEN
- SELF.font := font;
- Changed;
- END;
- END;
- NotDefault;
- ReleaseWrite;
- END SetStyle;
- PROCEDURE GetSyle*() : SET;
- VAR font : WMGraphics.Font;
- BEGIN
- font := Get();
- RETURN font.style;
- END GetSyle;
- PROCEDURE FromXML*(xml : XML.Element);
- VAR s : String; name : ARRAY 32 OF CHAR; size : LONGINT; style : SET;
- BEGIN
- s := xml.GetAttributeValue("name");
- IF (s # NIL) THEN COPY(s^, name); ELSE name := ""; END;
- s := xml.GetAttributeValue("size");
- IF (s # NIL) THEN Strings.StrToInt(s^, size); ELSE size := 0; END;
- s := xml.GetAttributeValue("style");
- IF (s # NIL) THEN Strings.StrToSet(s^, style); ELSE style := {}; END;
- SetFont(name, size, style);
- END FromXML;
- PROCEDURE ToXML*(VAR element: XML.Element);
- VAR s: ARRAY 32 OF CHAR;
- BEGIN
- IF (GetName # NIL) & nonDefault THEN
- ToXML^(element);
- element.SetAttributeValue("loader","WMProperties.NewFont");
- element.SetAttributeValue("name",font.name);
- Strings.IntToStr(font.size, s);
- element.SetAttributeValue("size",s);
- Strings.SetToStr(font.style, s);
- element.SetAttributeValue("style",s);
- END;
- END ToXML;
- PROCEDURE WriteXML*(w : Streams.Writer; context: ANY; indent : LONGINT);
- VAR name : String; font : WMGraphics.Font; temp : ARRAY 32 OF CHAR;
- BEGIN
- name := GetName();
- IF name = NIL THEN KernelLog.String("Nameless boolean property encountered. Ignored"); KernelLog.Ln; RETURN END;
- IF nonDefault THEN
- font := Get();
- Indent(w, indent);
- w.Char("<"); w.String(name^); w.String(' loader="WMProperties.NewFont"');
- w.String(' name="'); w.String(font.name); w.String('" size="'); w.Int(font.size, 0); w.String('" style="');
- Strings.SetToStr(font.style, temp); w.String(temp); w.String('"');
- w.String("/>");
- w.Ln;
- END
- END WriteXML;
- END FontProperty;
- TYPE
- (** Accessor property to an Point (in integer coordinates). *)
- PointProperty*= OBJECT(Property)
- VAR
- value : WMGraphics.Point2d;
- PROCEDURE FromStream*(r : Streams.Reader);
- VAR new : WMGraphics.Point2d;
- BEGIN
- AcquireWrite;
- r.SkipWhitespace; r.Int(new.x, FALSE);
- r.SkipWhitespace; r.Int(new.y, FALSE);
- NotDefault;
- IF (new.x=value.x) & (new.y=value.y) THEN
- value := new;
- Changed;
- END;
- ReleaseWrite
- END FromStream;
- PROCEDURE ToStream*(w : Streams.Writer);
- BEGIN
- AcquireRead;
- w.Int(value.x, 0); w.Char(" ");
- w.Int(value.y, 0);
- ReleaseRead
- END ToStream;
- PROCEDURE Get*() : WMGraphics.Point2d;
- VAR r : WMGraphics.Point2d;
- BEGIN
- AcquireRead;
- IF nonDefault OR (prototype = NIL) THEN r := value
- ELSE r := prototype(PointProperty).Get()
- END;
- ReleaseRead;
- RETURN r
- END Get;
- PROCEDURE Set*(value : WMGraphics.Point2d);
- BEGIN
- AcquireWrite;
- IF (SELF.value.x#value.x) OR (SELF.value.y#value.y) THEN
- SELF.value:=value;
- IF object # NIL THEN UpdateModel END;
- Changed;
- ELSIF ~nonDefault THEN Changed
- END;
- NotDefault;
- ReleaseWrite
- END Set;
- (* set without updates -- use only when you definitely want to avoid updates *)
- PROCEDURE SetPassive*(value : WMGraphics.Point2d);
- BEGIN
- AcquireWrite;
- SELF.value := value;
- NotDefault;
- ReleaseWrite
- END SetPassive;
- PROCEDURE SetCoordinate*(x,y : LONGINT);
- BEGIN
- AcquireWrite;
- IF (x#value.x) OR (y#value.y) THEN
- value.x:=x; value.y:=y;
- Changed
- END;
- NotDefault;
- ReleaseWrite
- END SetCoordinate;
- PROCEDURE GetCoordinate*(VAR x,y: LONGINT);
- BEGIN
- x:=value.x; y:=value.y
- END GetCoordinate;
- PROCEDURE SetX*(x : LONGINT);
- BEGIN
- AcquireWrite;
- IF value.x # x THEN value.x := x; Changed END; NotDefault;
- ReleaseWrite
- END SetX;
- PROCEDURE SetY*(y : LONGINT);
- BEGIN
- AcquireWrite;
- IF value.y # y THEN value.y := y; Changed END; NotDefault;
- ReleaseWrite
- END SetY;
- PROCEDURE GetX*() : LONGINT;
- BEGIN
- RETURN value.x
- END GetX;
- PROCEDURE GetY*(): LONGINT;
- BEGIN
- RETURN value.y
- END GetY;
- PROCEDURE FromXML*(xml : XML.Element);
- VAR en : XMLObjects.Enumerator; p : ANY; s: String;
- BEGIN
- AcquireWrite;
- en := xml.GetContents();
- WHILE en.HasMoreElements() DO
- IF en.HasMoreElements() THEN
- p := en.GetNext();
- IF (p IS XML.Element) THEN
- s := p(XML.Element).GetName();
- IF s # NIL THEN
- IF s^ = "X" THEN SetX(ReadCharDataInt(p(XML.Element)))
- ELSIF s^ = "Y" THEN SetY(ReadCharDataInt(p(XML.Element)))
- END
- END
- END
- END
- END;
- Stamp;
- ReleaseWrite
- END FromXML;
- PROCEDURE ToXML*(VAR element: XML.Element);
- VAR cs: ARRAY 10 OF CHAR; sub: XML.Element; t: WMGraphics.Point2d;
- BEGIN
- IF (GetName # NIL) & nonDefault THEN
- ToXML^(element);
- element.SetAttributeValue("loader","WMProperties.NewPoint");
- t := Get();
- NEW(sub); sub.SetName("X"); element.AddContent(sub);
- sub.AddContent(NewIntChars(t.x));
- NEW(sub); sub.SetName("Y");element.AddContent(sub);
- sub.AddContent(NewIntChars(t.y));
- END;
- END ToXML;
- PROCEDURE WriteXML*(w : Streams.Writer; context: ANY; indent : LONGINT);
- VAR name : String; t : WMGraphics.Point2d;
- BEGIN
- name := GetName();
- IF name = NIL THEN KernelLog.String("Nameless point property encountered. Ignored"); KernelLog.Ln; RETURN END;
- IF nonDefault THEN
- t := Get();
- Indent(w, indent);w.Char("<"); w.String(name^); w.String(' loader="WMProperties.NewPoint"'); w.Char(">"); w.Ln;
- Indent(w, indent + 1); w.String("<X>"); w.Int(t.x, 0); w.String("</X>"); w.Ln;
- Indent(w, indent + 1); w.String("<Y>"); w.Int(t.y, 0); w.String("</Y>"); w.Ln;
- Indent(w, indent); w.String("</"); w.String(name^); w.Char(">"); w.Ln;
- END
- END WriteXML;
- END PointProperty;
- TYPE
- (** Accessor property to an integer value. The range of possible values can be restricted. *)
- RectangleProperty* = OBJECT(Property)
- VAR
- value : WMRectangles.Rectangle;
- PROCEDURE FromStream*(r : Streams.Reader);
- VAR new : WMRectangles.Rectangle;
- BEGIN
- AcquireWrite;
- r.SkipWhitespace; r.Int(new.l, FALSE);
- r.SkipWhitespace; r.Int(new.t, FALSE);
- r.SkipWhitespace; r.Int(new.r, FALSE);
- r.SkipWhitespace; r.Int(new.b, FALSE);
- NotDefault;
- IF ~WMRectangles.IsEqual(new, value) THEN
- value := new;
- Changed;
- END;
- ReleaseWrite
- END FromStream;
- PROCEDURE ToStream*(w : Streams.Writer);
- BEGIN
- AcquireRead;
- w.Int(value.l, 0); w.Char(" "); w.Int(value.t, 0); w.Char(" ");
- w.Int(value.r, 0); w.Char(" "); w.Int(value.b, 0);
- ReleaseRead
- END ToStream;
- PROCEDURE Get*() : WMRectangles.Rectangle;
- VAR r : WMRectangles.Rectangle;
- BEGIN
- AcquireRead;
- IF nonDefault OR (prototype = NIL) THEN r := value
- ELSE r := prototype(RectangleProperty).Get()
- END;
- ReleaseRead;
- RETURN r
- END Get;
- PROCEDURE Set*(value : WMRectangles.Rectangle);
- BEGIN
- AcquireWrite;
- IF (SELF.value.l # value.l) OR (SELF.value.t # value.t) OR
- (SELF.value.r # value.r) OR (SELF.value.b # value.b) THEN
- SELF.value := value; Changed;
- IF object # NIL THEN UpdateModel END;
- ELSIF ~nonDefault THEN Changed
- END;
- NotDefault;
- ReleaseWrite
- END Set;
- (* set without updates -- use only when you definitely want to avoid updates *)
- PROCEDURE SetPassive*(value : WMRectangles.Rectangle);
- BEGIN
- AcquireWrite;
- SELF.value := value;
- NotDefault;
- ReleaseWrite
- END SetPassive;
- PROCEDURE SetWidth*(w : LONGINT);
- BEGIN
- AcquireWrite;
- IF GetWidth() # w THEN Changed END; value.r := value.l + w; NotDefault;
- ReleaseWrite
- END SetWidth;
- PROCEDURE SetHeight*(h : LONGINT);
- BEGIN
- AcquireWrite;
- IF GetHeight() # h THEN Changed END; value.b := value.t + h; NotDefault;
- ReleaseWrite
- END SetHeight;
- PROCEDURE SetLeft*(l : LONGINT);
- BEGIN
- AcquireWrite;
- IF value.l # l THEN Changed END; value.r := l + GetWidth(); value.l := l; NotDefault;
- ReleaseWrite
- END SetLeft;
- PROCEDURE SetTop*(t : LONGINT);
- BEGIN
- AcquireWrite;
- IF value.t # t THEN Changed END; value.b := t + GetHeight(); value.t := t; NotDefault;
- ReleaseWrite
- END SetTop;
- PROCEDURE SetRight*(r : LONGINT);
- BEGIN
- AcquireWrite;
- IF value.r # r THEN Changed END; value.r := r; NotDefault;
- ReleaseWrite
- END SetRight;
- PROCEDURE SetBottom*(b : LONGINT);
- BEGIN
- AcquireWrite;
- IF value.b # b THEN Changed END; value.b := b; NotDefault;
- ReleaseWrite
- END SetBottom;
- PROCEDURE SetExtents*(w, h : LONGINT);
- BEGIN
- AcquireWrite; (* protective transaction *)
- SetWidth(w); SetHeight(h);
- ReleaseWrite
- END SetExtents;
- PROCEDURE GetWidth*() : LONGINT;
- VAR r : WMRectangles.Rectangle;
- BEGIN
- r := Get();
- RETURN r.r - r.l;
- END GetWidth;
- PROCEDURE GetHeight*() : LONGINT;
- VAR r : WMRectangles.Rectangle;
- BEGIN
- r := Get();
- RETURN r.b - r.t;
- END GetHeight;
- PROCEDURE GetLeft*() : LONGINT;
- VAR r : WMRectangles.Rectangle;
- BEGIN
- r := Get();
- RETURN r.l;
- END GetLeft;
- PROCEDURE GetTop*() : LONGINT;
- VAR r : WMRectangles.Rectangle;
- BEGIN
- r := Get();
- RETURN r.t;
- END GetTop;
- PROCEDURE GetRight*() : LONGINT;
- VAR r : WMRectangles.Rectangle;
- BEGIN
- r := Get();
- RETURN r.r;
- END GetRight;
- PROCEDURE GetBottom*() : LONGINT;
- VAR r : WMRectangles.Rectangle;
- BEGIN
- r := Get();
- RETURN r.b;
- END GetBottom;
- PROCEDURE GetExtents*(VAR width, height : LONGINT);
- VAR r : WMRectangles.Rectangle;
- BEGIN
- r := Get();
- width := r.r - r.l;
- height := r.b - r.t;
- END GetExtents;
- PROCEDURE FromXML*(xml : XML.Element);
- VAR en : XMLObjects.Enumerator; p : ANY; s: String;
- BEGIN
- AcquireWrite;
- en := xml.GetContents();
- WHILE en.HasMoreElements() DO
- IF en.HasMoreElements() THEN
- p := en.GetNext();
- IF (p IS XML.Element) THEN
- s := p(XML.Element).GetName();
- IF s # NIL THEN
- IF s^ = "Left" THEN SetLeft(ReadCharDataInt(p(XML.Element)))
- ELSIF s^ = "Top" THEN SetTop(ReadCharDataInt(p(XML.Element)))
- ELSIF s^ = "Right" THEN SetRight(ReadCharDataInt(p(XML.Element)))
- ELSIF s^ = "Bottom" THEN SetBottom(ReadCharDataInt(p(XML.Element)))
- ELSIF s^ = "Width" THEN SetWidth(ReadCharDataInt(p(XML.Element)))
- ELSIF s^ = "Height" THEN SetHeight(ReadCharDataInt(p(XML.Element)))
- END
- END
- END
- END
- END;
- Stamp;
- ReleaseWrite
- END FromXML;
- PROCEDURE ToXML*(VAR element: XML.Element);
- VAR cs: ARRAY 10 OF CHAR; sub: XML.Element; t: WMRectangles.Rectangle;
- BEGIN
- IF (GetName # NIL) & nonDefault THEN
- ToXML^(element);
- element.SetAttributeValue("loader","WMProperties.NewRectangle");
- t := Get();
- NEW(sub); sub.SetName("Left"); element.AddContent(sub);
- sub.AddContent(NewIntChars(t.l));
- NEW(sub); sub.SetName("Top");element.AddContent(sub);
- sub.AddContent(NewIntChars(t.t));
- NEW(sub); sub.SetName("Width");element.AddContent(sub);
- sub.AddContent(NewIntChars(t.r-t.l));
- NEW(sub); sub.SetName("Height");element.AddContent(sub);
- sub.AddContent(NewIntChars(t.b-t.t));
- END;
- END ToXML;
- PROCEDURE WriteXML*(w : Streams.Writer; context: ANY; indent : LONGINT);
- VAR name : String; t : WMRectangles.Rectangle;
- BEGIN
- name := GetName();
- IF name = NIL THEN KernelLog.String("Nameless rectangle property encountered. Ignored"); KernelLog.Ln; RETURN END;
- IF nonDefault THEN
- t := Get();
- Indent(w, indent);w.Char("<"); w.String(name^); w.String(' loader="WMProperties.NewRectangle"'); w.Char(">"); w.Ln;
- Indent(w, indent + 1); w.String("<Left>"); w.Int(t.l, 0); w.String("</Left>"); w.Ln;
- Indent(w, indent + 1); w.String("<Top>"); w.Int(t.t, 0); w.String("</Top>"); w.Ln;
- Indent(w, indent + 1); w.String("<Width>"); w.Int(t.r-t.l, 0); w.String("</Width>"); w.Ln;
- Indent(w, indent + 1); w.String("<Height>"); w.Int(t.b-t.t, 0); w.String("</Height>"); w.Ln;
- Indent(w, indent); w.String("</"); w.String(name^); w.Char(">"); w.Ln;
- END
- END WriteXML;
- END RectangleProperty;
- TYPE
- ReferenceProperty* = OBJECT(Property)
- VAR
- (*
- object : Repositories.Component;
- repositoryName : Strings.String;
- componentName : Strings.String;
- generator : Strings.String;
- componentID : LONGINT;
- *)
- (* temporary used in WriteXML *)
- level: LONGINT;
- PROCEDURE &NewRef*(prototype : Property; name, info : String);
- BEGIN
- New(prototype, name, info);
- END NewRef;
- PROCEDURE FromStream*(r : Streams.Reader);
- VAR
- fullname, repositoryName : ARRAY 256 OF CHAR; componentName : ARRAY 128 OF CHAR;
- writer : Streams.Writer; buffer : Strings.Buffer; ch : CHAR;
- BEGIN
- r.String(fullname);
- IF Repositories.IsCommandString(fullname) THEN
- AcquireWrite;
- SELF.repositoryName := NIL;
- SELF.componentName := NIL;
- componentID := 0;
- NEW(buffer, 256); writer := buffer.GetWriter();
- writer.String(fullname);
- WHILE (r.res = Streams.Ok) DO
- r.Char(ch); writer.Char(ch);
- END;
- SELF.generator := buffer.GetString();
- ReleaseWrite;
- ELSIF Repositories.SplitName(fullname, repositoryName, componentName, SELF.componentID) THEN
- AcquireWrite;
- NotDefault;
- SELF.repositoryName := Strings.NewString(repositoryName);
- SELF.componentName := Strings.NewString(componentName);
- generator := NIL;
- ReleaseWrite
- ELSE
- AcquireWrite;
- SELF.repositoryName := NIL;
- SELF.componentName := NIL;
- componentID := 0;
- generator := NIL;
- ReleaseWrite
- END;
- END FromStream;
- PROCEDURE ToStream*(w : Streams.Writer);
- BEGIN
- AcquireRead;
- IF (generator # NIL) THEN
- w.String(generator^);
- ELSIF (repositoryName # NIL) & (componentName # NIL) THEN
- w.String(repositoryName^); w.String(":"); w.String(componentName^); w.String(":"); w.Int(componentID, 0);
- ELSIF (object # NIL) THEN
- w.Ln;
- Indent(w,level); object.Write(w, NIL, level);
- w.Ln; Indent(w,level-1);
- END;
- ReleaseRead
- END ToStream;
- PROCEDURE Get*() : Repositories.Component;
- VAR object : Repositories.Component; context : Repositories.Context; res : WORD;
- BEGIN
- AcquireRead;
- object := SELF.object;
- ReleaseRead;
- (* late time generation of object for supporting of loading repositories *)
- IF (object = NIL) THEN
- IF (generator # NIL) THEN
- Repositories.CallCommand(generator^, context, res);
- IF (res = Repositories.Ok) & (context.object # NIL) & (context.object IS Repositories.Component) THEN
- object := context.object(Repositories.Component);
- Set(object)
- END;
- ELSIF (repositoryName # NIL) & (componentName # NIL) THEN
- Repositories.GetComponent(repositoryName^, componentName^, componentID, object, res);
- Set(object);
- ELSIF (componentName # NIL) & (repository # NIL) THEN
- object := repository.GetComponent(componentName^, componentID);
- Set(object);
- END;
- END;
- RETURN object
- END Get;
- PROCEDURE Set*(object : Repositories.Component);
- BEGIN
- AcquireWrite; (* TBD: Store object to repository *)
- IF (SELF.object # object) THEN
- ReplaceLink(object); Changed;
- ELSIF ~ nonDefault THEN Changed END;
- NotDefault;
- ReleaseWrite;
- END Set;
- (* set without updates -- use only when you definitely want to avoid updates *)
- PROCEDURE SetPassive*(object : Repositories.Component);
- BEGIN
- AcquireWrite;
- ReplaceLink(object);
- NotDefault;
- ReleaseWrite
- END SetPassive;
- PROCEDURE LinkChanged(sender, object: ANY);
- BEGIN
- IF (list # NIL) THEN list.onLinkChanged.CallWithSender(SELF,object) END;
- END LinkChanged;
- PROCEDURE SetAsString*(CONST string : ARRAY OF CHAR);
- BEGIN
- SetLinkAsString(string)
- END SetAsString;
- PROCEDURE GetAsString*(VAR string : ARRAY OF CHAR);
- BEGIN
- GetLinkAsString(string)
- END GetAsString;
- PROCEDURE Reset*;
- BEGIN
- AcquireWrite;
- ReplaceLink(NIL);
- repositoryName := NIL; componentName := NIL; componentID := 0;
- generator := NIL;
- NotDefault;
- Changed;
- ReleaseWrite;
- END Reset;
- PROCEDURE FromXML*(xml : XML.Element);
- VAR en : XMLObjects.Enumerator; p : ANY; s : String;
- BEGIN
- ReplaceLink(NIL);
- object := NIL;
- repositoryName := NIL; componentName := NIL;
- componentID := 0;
- en := xml.GetContents();
- p := en.GetNext();
- NotDefault;
- IF (p # NIL ) & (p IS XML.Chars) THEN
- s := p(XML.Chars).GetStr();
- IF s # NIL THEN
- Strings.Trim(s^, " ");
- SetAsString(s^);
- object := Get();
- END
- ELSIF (p # NIL) & (p IS XML.Element) THEN
- ReplaceLink( Repositories.ComponentFromXML(p(XML.Element)));
- END
- END FromXML;
- PROCEDURE ToXML*(VAR element: XML.Element);
- VAR cs: ARRAY 10 OF CHAR; sub: XML.Element; t: WMRectangles.Rectangle;
- BEGIN
- IF (GetName # NIL) & nonDefault THEN
- ToXML^(element);
- element.SetAttributeValue("loader","WMProperties.NewReference");
- (*??? how to represent this ? *)
- END;
- END ToXML;
- PROCEDURE WriteXML*(w : Streams.Writer; context: ANY; indent : LONGINT);
- VAR name : String; id: LONGINT; res: WORD; repository: Repositories.Repository; objectName: String;
- BEGIN
- name := GetName();
- IF name = NIL THEN KernelLog.String("Nameless boolean property encountered. Ignored"); KernelLog.Ln; RETURN END;
- IF nonDefault THEN
- Indent(w, indent);
- level := indent+1;
- w.Char("<"); w.String(name^); w.String(' loader="WMProperties.NewReference"'); w.Char(">");
- IF (context # NIL) & (context IS Repositories.StoreContext) & (object # NIL) THEN
- repository := context(Repositories.StoreContext).repository;
- id := 1;
- objectName := object.GetName();
- IF (objectName=NIL) OR (objectName^="") THEN objectName :=anonymous END;
- repository.PutComponent(object, objectName^,id,res);
- w.String(":"); (* <-- THIS repository *) w.String(objectName^); w.String(":"); w.Int(id, 0);
- ELSE
- ToStream(w);
- END;
- w.String("</"); w.String(name^); w.Char(">"); w.Ln;
- END
- END WriteXML;
- PROCEDURE Finalize*;
- BEGIN
- AcquireWrite;
- ReplaceLink(NIL);
- ReleaseWrite;
- END Finalize;
- END ReferenceProperty;
- TYPE
- PropertyArray* = POINTER TO ARRAY OF Property;
- PropertyList* = OBJECT
- VAR
- properties : PropertyArray;
- nofProperties- : LONGINT;
- onPropertyChanged- : WMEvents.EventSource;
- onLinkChanged-: WMEvents.EventSource;
- lock : Locks.RWLock;
- upNofChanges : LONGINT;
- upChanged : Property;
- propertyChanged, linkChanged: WMEvents.EventListener;
- PROCEDURE &New*;
- BEGIN
- NEW(properties, 8);
- NEW(onPropertyChanged, SELF, StringProperties, StringPropertiesInfo, NIL);
- NEW(onLinkChanged, SELF, StringLinks, StringLinksInfo, NIL);
- NEW(lock)
- END New;
- (** acquire a write lock on the object *)
- PROCEDURE AcquireWrite*;
- BEGIN
- lock.AcquireWrite
- END AcquireWrite;
- (** release the write lock on the object *)
- PROCEDURE ReleaseWrite*;
- VAR
- removeLock : BOOLEAN;
- changed : Property; nofChanges : LONGINT;
- BEGIN
- removeLock := lock.GetWLockLevel() = 1;
- IF removeLock THEN
- changed := upChanged; nofChanges := upNofChanges;
- upNofChanges := 0; upChanged := NIL;
- END;
- lock.ReleaseWrite;
- IF removeLock THEN
- IF nofChanges = 1 THEN onPropertyChanged.Call(changed)
- ELSIF nofChanges > 0 THEN onPropertyChanged.Call(SELF)
- END
- END
- END ReleaseWrite;
- PROCEDURE AcquireRead;
- BEGIN
- lock.AcquireRead
- END AcquireRead;
- PROCEDURE ReleaseRead;
- BEGIN
- lock.ReleaseRead
- END ReleaseRead;
- PROCEDURE Add*(x : Property);
- BEGIN
- AcquireWrite;
- x.list := SELF;
- IF nofProperties = LEN(properties) THEN Grow END;
- properties[nofProperties] := x;
- INC(nofProperties);
- ReleaseWrite
- END Add;
- PROCEDURE Remove*(x : Property);
- VAR i : LONGINT;
- BEGIN
- AcquireWrite;
- i := 0; WHILE (i < nofProperties) & (properties[i] # x) DO INC(i) END;
- IF i < nofProperties THEN
- WHILE (i < nofProperties - 1) DO properties[i] := properties[i + 1]; INC(i) END;
- DEC(nofProperties);
- properties[nofProperties] := NIL
- END;
- ReleaseWrite
- END Remove;
- PROCEDURE Get*(CONST name : ARRAY OF CHAR) : Property;
- VAR property : Property; n : String; i : LONGINT;
- BEGIN
- AcquireRead;
- i := 0; property := NIL;
- WHILE (i < nofProperties) & (property = NIL) DO
- n := properties[i].GetName();
- IF (n # NIL) & (n^ = name) THEN
- property := properties[i];
- END;
- INC(i);
- END;
- ReleaseRead;
- RETURN property;
- END Get;
- PROCEDURE Grow;
- VAR new: PropertyArray; i : LONGINT;
- BEGIN
- NEW(new, LEN(properties) * 2);
- FOR i := 0 TO nofProperties - 1 DO new[i] := properties[i] END;
- properties := new
- END Grow;
- PROCEDURE Enumerate*() : PropertyArray;
- VAR current : PropertyArray; i : LONGINT;
- BEGIN
- AcquireWrite;
- NEW(current, nofProperties);
- FOR i := 0 TO nofProperties - 1 DO current[i] := properties[i] END;
- ReleaseWrite;
- RETURN current
- END Enumerate;
- PROCEDURE HasProperty*(CONST name : ARRAY OF CHAR) : BOOLEAN;
- VAR n : Strings.String; found : BOOLEAN; i : LONGINT;
- BEGIN
- found := FALSE;
- AcquireRead;
- i := 0;
- WHILE ~found & (i < nofProperties) DO
- n := properties[i].GetName();
- found := (n # NIL) & (n^ = name);
- INC(i);
- END;
- ReleaseRead;
- RETURN found;
- END HasProperty;
- PROCEDURE GetPropertyValue*(CONST name : ARRAY OF CHAR; VAR value : ARRAY OF CHAR) : BOOLEAN;
- VAR i : LONGINT; n : String; vs : Streams.StringWriter; len : LONGINT;
- BEGIN
- AcquireRead;
- i := 0;
- WHILE i < nofProperties DO
- n := properties[i].GetName();
- IF (n # NIL) & (n^ = name) THEN
- len := LEN(value);
- NEW(vs, LEN(value)); vs.GetRaw(value, len);
- properties[i].ToStream(vs);
- vs.Get(value);
- ReleaseRead;
- RETURN TRUE;
- END;
- INC(i);
- END;
- ReleaseRead;
- RETURN FALSE;
- END GetPropertyValue;
- PROCEDURE SetPropertyValue*(CONST name, value: ARRAY OF CHAR) : BOOLEAN;
- VAR i : LONGINT; n : String; vs : Streams.StringReader;
- BEGIN
- AcquireWrite;
- i := 0;
- WHILE i < nofProperties DO
- n := properties[i].GetName();
- IF (n # NIL) & (n^ = name) THEN
- NEW(vs, LEN(value)); vs.SetRaw(value, 0, LEN(value));
- properties[i].FromStream(vs); i := nofProperties
- END;
- INC(i)
- END;
- ReleaseWrite;
- RETURN (i > nofProperties) (* if no success, then i=nofProperties; patch PH 06/12 *)
- END SetPropertyValue;
- PROCEDURE SetXML*(xml : XML.Element);
- VAR
- en : XMLObjects.Enumerator;
- p : ANY; s, n : String; i : LONGINT;
- repository: Repositories.Repository;
- BEGIN
- AcquireWrite;
- IF xml IS Repositories.Properties THEN repository := xml(Repositories.Properties).repository ELSE repository := NIL END;
- en := xml.GetContents();
- WHILE en.HasMoreElements() DO
- p := en.GetNext();
- IF p IS XML.Element THEN
- s := p(XML.Element).GetName();
- i := 0;
- WHILE i < nofProperties DO
- properties[i].repository := repository;
- n := properties[i].GetName();
- IF (n # NIL) & (n^ = s^) THEN
- properties[i].FromXML(p(XML.Element)); i := nofProperties
- END;
- INC(i)
- END
- END
- END;
- ReleaseWrite
- END SetXML;
- PROCEDURE FromXML*(xml: XML.Element);
- VAR generator: PROCEDURE(): Property;
- VAR
- property: Property;
- l: Strings.String;
- en : XMLObjects.Enumerator;
- p : ANY; s, n : String; i : LONGINT;
- moduleName, procedureName: Modules.Name;
- res: WORD; msg: ARRAY 32 OF CHAR;
- found: BOOLEAN;
- BEGIN
- IF xml # NIL THEN
- AcquireWrite;
- en := xml.GetContents();
- WHILE en.HasMoreElements() DO
- p := en.GetNext();
- IF p IS XML.Element THEN
- s := p(XML.Element).GetName();
- (* check if property is already there (and potentially linked in application, in which case it should not be reinstalled *)
- i := 0; found := FALSE;
- WHILE (i < nofProperties) & ~found DO
- n := properties[i].GetName();
- IF (n # NIL) & (n^ = s^) THEN
- found := TRUE;
- properties[i].FromXML(p(XML.Element)); i := nofProperties
- END;
- INC(i)
- END;
- IF ~found THEN
- l := p(XML.Element).GetAttributeValue("loader");
- IF l # NIL THEN
- Commands.Split(l^, moduleName, procedureName, res, msg);
- IF (res = Commands.Ok) THEN
- GETPROCEDURE(moduleName, procedureName, generator);
- IF (generator # NIL) THEN
- property := generator();
- IF (property # NIL) THEN
- property.New(NIL, s, NIL);
- property.FromXML(p(XML.Element));
- Add(property);
- END;
- END;
- END;
- END;
- END;
- END
- END;
- ReleaseWrite
- END;
- END FromXML;
- PROCEDURE ToXML*(VAR element: XML.Element);
- VAR sub: XML.Element; i : LONGINT; self: ANY;
- BEGIN
- NEW(element); element.SetName("Properties");
- FOR i := 0 TO nofProperties-1 DO
- sub := NIL;
- properties[i].ToXML(sub);
- IF sub # NIL THEN
- element.AddContent(sub);
- END;
- END;
- END ToXML;
- PROCEDURE WriteXML*(w : Streams.Writer; context: ANY; indent : LONGINT);
- VAR i : LONGINT;
- BEGIN
- w.Ln;
- Indent(w, indent + 1);
- w.String("<Properties>"); w.Ln;
- AcquireRead;
- FOR i := 0 TO nofProperties - 1 DO
- properties[i].WriteXML(w, context, indent + 2)
- END;
- Indent(w, indent + 1);
- w.String("</Properties>");
- ReleaseRead
- END WriteXML;
- (*
- PROCEDURE ToRepository*(CONST repository: ARRAY OF CHAR; w : Streams.Writer; indent : LONGINT);
- VAR i : LONGINT;
- BEGIN
- w.Ln;
- Indent(w, indent + 1);
- w.String("<Properties>"); w.Ln;
- AcquireRead;
- FOR i := 0 TO nofProperties - 1 DO
- properties[i].ToRepository(repository, w, indent + 2)
- END;
- Indent(w, indent + 1);
- w.String("</Properties>");
- ReleaseRead
- END ToRepository;
- *)
- PROCEDURE Changed(p : Property);
- BEGIN (* {EXCLUSIVE} *)
- IF p # upChanged THEN INC(upNofChanges); upChanged := p END;
- END Changed;
- PROCEDURE Finalize*;
- VAR i: LONGINT;
- BEGIN
- AcquireWrite;
- FOR i := 0 TO nofProperties - 1 DO
- properties[i].Finalize
- END;
- ReleaseWrite;
- END Finalize;
- END PropertyList;
- Properties* = Repositories.Properties;
- VAR
- StringProperties, StringLinks : String;
- StringPropertiesInfo, StringLinksInfo : String;
- anonymous: String;
- PROCEDURE Indent(w : Streams.Writer; indent : LONGINT);
- VAR i : LONGINT;
- BEGIN
- FOR i := 0 TO indent - 1 DO w.Char(9X) END
- END Indent;
- PROCEDURE ReadCharDataInt(xml : XML.Element) : LONGINT;
- VAR en : XMLObjects.Enumerator;
- p : ANY; s : String; value : LONGINT;
- BEGIN
- value := 0;
- en := xml.GetContents();
- IF en.HasMoreElements() THEN
- p := en.GetNext();
- IF p IS XML.Chars THEN
- s := p(XML.Chars).GetStr();
- IF s # NIL THEN Strings.StrToInt(s^, value) END
- END;
- END;
- RETURN value
- END ReadCharDataInt;
- PROCEDURE NewIntChars(i: LONGINT): XML.Chars;
- VAR chars: XML.ArrayChars; s: ARRAY 32 OF CHAR;
- BEGIN
- NEW(chars);
- Strings.IntToStr(i, s);
- chars.SetStr(s);
- RETURN chars
- END NewIntChars;
- PROCEDURE NewBoolean*(): Property;
- VAR property: BooleanProperty;
- BEGIN NEW(property,NIL,NIL,NIL); RETURN property
- END NewBoolean;
- PROCEDURE NewSet*(): Property;
- VAR property: SetProperty;
- BEGIN NEW(property,NIL,NIL,NIL); RETURN property
- END NewSet;
- PROCEDURE NewInt32*(): Property;
- VAR property: Int32Property;
- BEGIN NEW(property,NIL,NIL,NIL); RETURN property
- END NewInt32;
- PROCEDURE NewReal*(): Property;
- VAR property: RealProperty;
- BEGIN NEW(property,NIL,NIL,NIL); RETURN property
- END NewReal;
- PROCEDURE NewString*(): Property;
- VAR property: StringProperty;
- BEGIN NEW(property,NIL,NIL,NIL); RETURN property
- END NewString;
- PROCEDURE NewColor*(): Property;
- VAR property: ColorProperty;
- BEGIN NEW(property,NIL,NIL,NIL); RETURN property
- END NewColor;
- PROCEDURE NewFont*(): Property;
- VAR property: FontProperty;
- BEGIN NEW(property,NIL,NIL,NIL); RETURN property
- END NewFont;
- PROCEDURE NewPoint*(): Property;
- VAR property: PointProperty;
- BEGIN NEW(property,NIL,NIL,NIL); RETURN property
- END NewPoint;
- PROCEDURE NewRectangle*(): Property;
- VAR property: RectangleProperty;
- BEGIN NEW(property,NIL,NIL,NIL); RETURN property
- END NewRectangle;
- PROCEDURE NewReference*(): Property;
- VAR property: ReferenceProperty;
- BEGIN NEW(property,NIL,NIL,NIL); RETURN property
- END NewReference;
- (* Get a model from either a property reference or a model pointer *)
- PROCEDURE GetModel*(ref: ANY; VAR m: Models.Model): BOOLEAN;
- BEGIN
- IF (ref # NIL) & (ref IS ReferenceProperty) THEN ref := ref(ReferenceProperty).Get() END;
- IF (ref # NIL) & (ref IS Models.Model) THEN m := ref(Models.Model); RETURN TRUE END;
- RETURN FALSE
- END GetModel;
- BEGIN
- StringProperties := Strings.NewString("PropertyChanged");
- StringLinks := Strings.NewString("LinkChanged");
- StringPropertiesInfo := Strings.NewString("the event is called if a property in the list is changed");
- StringLinksInfo := Strings.NewString("the event is called if a link in a reference property in the list is changed");
- anonymous := Strings.NewString("ANONYMOUS");
- END WMProperties.
|