123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732 |
- MODULE WMComponents; (** AUTHOR "TF"; PURPOSE "Component Framework based on XML"; *)
- (**
- -- Events: --
- Each VisualComponent can produce keyboard and mouse events which can trigger A2 commands.
- The command string for a given event can by specified by the usage of XML attributes and component properties.
- The following attributes are defined:
- Keyboard: onReturn, onEscape, onKeyPressed, onKeyReleased
- Mouse: onLeftClick, onRightClick, onMiddleClick, onClick
- The command strings are processed (macro substitution) before the actual command is called.
- -- Macro substitution: --
- General form: "^" [namespace ":"] macrostring
- A macro always start with MacroCharacter ("^"). The next occurence of a whitespace character determines the end of the macro.
- Two consequent MacroCharacter's ("^^") will be replaced by the MacroCharacter ("^") not triggering macro substitution at all.
- The user can install MacroHandlerProcedures for a given namespace. At most one handler per namespace can be installed.
- If the namespace is omitted, the default macro handler is triggered.
- The DefaultMacroHandler currently supports the following macro substitutions:
- ^selection is replaced by the last selection of the user
- ^clipboard is replaced by the content of the clipboard
- ^attribute=[component "."] attribute
- ^property=[component "."] property
- is replaced by the value of <attribute> or <property>.
- If the component qualifier is omitted, <attribute> or <property> is supposed to be an attribute or property of the originator of the event.
- If no MacroHandlerProcedure is found for a given macro, no substitution takes place.
- Example:
- onLeftClick = SystemTools.Show ^attribute=generator
- onMiddleClick = SystemTools.Show ^property=FillColor
- *)
- (*PH 08/14:
- - avoid parallel call of FormWindow.SetContent, Component.AddContent, Form.InvalidateRect by different processes, through use of EXCLUSIVE sections.
- - send an "invalidate content" message to a window after it appears on the display, which is handled after "form" field is ready
- - restructure FormWindow.SetContent() to assure coherent displays and to assure FormWindow.content is consistent
- *)
- IMPORT
- KernelLog, Inputs, Streams, Events, Files, Texts, TextUtilities,
- XML, XMLScanner, XMLParser, XMLObjects, Codecs, Localization, Repositories,
- Messages := WMMessages, Rectangles := WMRectangles,
- WMEvents, WMProperties, WMGraphics, Strings, WM := WMWindowManager, Raster,
- Commands, Modules, Kernel, Locks, Objects, WMDropTarget;
- CONST
- Ok* = 0;
- DuplicateNamespace* = 1;
- AlignNone* = 0; AlignLeft* = 1; AlignTop* = 2; AlignRight* = 3; AlignBottom* = 4; AlignClient* = 5; AlignRelative*=6;
- None=0; Left=1; Right=2; Lower=3; Upper=4; LowerRight=5; UpperRight=6; LowerLeft=7; UpperLeft=8; Inside = 9;
- MaxRel = 16*1024;
- MaxComponentNameSize* = 64; (* including 0X *)
- TraceFocus = 0;
- TraceFinalize = 1;
- Trace = {};
- (* Enable event logging? *)
- Logging = TRUE;
- (* Macro handling *)
- (* General form of macro: MacroCharacter [Namespace + NamespaceCharacter] MacroName *)
- MacroCharacter = "^";
- NamespaceCharacter = ":";
- NoNamespace = "";
- (* Namespace used if no namespace is specified *)
- DefaultNamespace = "system";
- (* Macros names of default macro handler *)
- MacroSelection = "selection";
- MacroClipboard = "clipboard";
- MacroAttributePrefix = "attribute=";
- MacroPropertyPrefix = "property=";
- CanYield = TRUE;
-
- (*temporary - to be removed*)
- FlagDirty=13;
- TYPE
- (** Installable event preview handlers. Are called by the components sequencer thread *)
- PointerHandler* = PROCEDURE {DELEGATE} (x, y : LONGINT; keys : SET; VAR handled : BOOLEAN);
- PointerLeaveHandler* = PROCEDURE {DELEGATE} (VAR handled : BOOLEAN);
- DragDropHandler* = PROCEDURE {DELEGATE} (x, y : LONGINT; dragInfo : WM.DragInfo; VAR handled : BOOLEAN);
- DragResultHandler* = PROCEDURE {DELEGATE} (accepted : BOOLEAN; recipient : ANY; dragInfo : WM.DragInfo; VAR handled : BOOLEAN);
- DragAutoStartHandler* = PROCEDURE {DELEGATE} (VAR handled : BOOLEAN);
- FocusHandler* = PROCEDURE {DELEGATE} (hasFocus : BOOLEAN);
- ContextMenuHandler* = PROCEDURE {DELEGATE} (sender : ANY; x, y: LONGINT);
- KeyEventHandler* = PROCEDURE {DELEGATE} (ucs : LONGINT; flags : SET; VAR keySym : LONGINT; VAR handled : BOOLEAN);
- DrawHandler* = PROCEDURE {DELEGATE} (canvas : WMGraphics.Canvas);
- Recursion*= ENUM None*, FromComponent*, FromBottom* END;
- TYPE
- SetStringProcedure = PROCEDURE {DELEGATE} (CONST string : ARRAY OF CHAR; x,y : LONGINT; VAR res : LONGINT);
- DropTarget = OBJECT(WMDropTarget.DropTarget)
- VAR
- originator : ANY;
- setString : SetStringProcedure;
- x,y : LONGINT;
- PROCEDURE &Init(originator : ANY; setString : SetStringProcedure; x,y : LONGINT);
- BEGIN
- ASSERT(setString # NIL);
- SELF.originator := originator;
- SELF.setString := setString;
- SELF.x := x;
- SELF.y := y;
- END Init;
- PROCEDURE GetInterface(type : LONGINT) : WMDropTarget.DropInterface;
- VAR sdi : DropString;
- BEGIN
- IF (type = WMDropTarget.TypeString) THEN
- NEW(sdi, originator, setString, x,y); RETURN sdi;
- ELSE
- RETURN NIL;
- END;
- END GetInterface;
- END DropTarget;
- DropString = OBJECT(WMDropTarget.DropString)
- VAR
- originator : ANY;
- setString : SetStringProcedure;
- x,y : LONGINT;
- PROCEDURE &Init(originator : ANY; setString : SetStringProcedure; x,y : LONGINT);
- BEGIN
- ASSERT(setString # NIL);
- SELF.originator := originator;
- SELF.setString := setString;
- SELF.x := x; SELF.y := y;
- END Init;
- PROCEDURE Set(CONST string : ARRAY OF CHAR; VAR res : LONGINT);
- BEGIN
- setString(string, x,y, res);
- END Set;
- END DropString;
- LanguageExtension* = POINTER TO RECORD(Messages.MessageExtension)
- languages* : Localization.Languages;
- END;
- ToggleEditMode* = POINTER TO RECORD
- recursion*: Recursion;
- END;
- Event* = RECORD
- END;
- KeyPressedEvent* = RECORD(Event)
- ucs- : LONGINT;
- flags- : SET;
- keysym- : LONGINT;
- END;
- PointerEvent* = RECORD(Event)
- x-, y-, z- : LONGINT;
- keys- : SET;
- END;
- EventContext* = OBJECT(Repositories.Context)
- VAR
- originator- : Component; (** {originator # NIL} *)
- command- : Strings.String; (** {command # NIL}, immutable *)
- timestamp- : LONGINT;
- PROCEDURE &New*(originator : Component; command : Strings.String; in, arg : Streams.Reader; out, error : Streams.Writer; caller : OBJECT);
- BEGIN
- ASSERT((originator # NIL) & (command # NIL));
- SELF.originator := originator;
- SELF.command := command;
- Init(in, arg, out, error, caller);
- END New;
- END EventContext;
- PointerContext* = OBJECT(EventContext)
- VAR
- pointer- : PointerEvent;
- END PointerContext;
- KeyContext* = OBJECT(EventContext)
- VAR
- key- : KeyPressedEvent;
- END KeyContext;
- TYPE
- (** Basic component *)
- ComponentStyleChanged = OBJECT
- END ComponentStyleChanged;
- Component* = OBJECT(Repositories.Component)
- VAR
- sequencer- : Messages.MsgSequencer;
- initialized- : BOOLEAN;
- properties- : WMProperties.PropertyList;
- events- : WMEvents.EventSourceList;
- eventListeners- : WMEvents.EventListenerList;
- id-, uid- : WMProperties.StringProperty;
- enabled- : WMProperties.BooleanProperty;
- (* discard property changes that come from a property change within the same component*)
- inPropertyUpdate, inLinkUpdate : BOOLEAN;
- (* If TRUE, this component is supposed to be created and managed by its parent. It is not externalized. *)
- internal- : BOOLEAN;
- (* after Init() , calling Reset() implicitely by insertion into FormWindow or explicitely, thereby triggering Initialize() is required to render component responsive to messages *)
- PROCEDURE &Init*;
- BEGIN
- Init^;
- SetNameAsString(StrComponent);
- sequencer := NIL;
- initialized := FALSE;
- NEW(properties); properties.onPropertyChanged.Add(SELF.InternalPropertyChanged); properties.onLinkChanged.Add(SELF.InternalLinkChanged);
- NEW(events);
- NEW(eventListeners);
- NEW(id, PrototypeID, NIL, NIL); properties.Add(id);
- NEW(uid, PrototypeUID, NIL, NIL); properties.Add(uid);
- NEW(enabled, PrototypeEnabled, NIL, NIL); properties.Add(enabled);
- inPropertyUpdate := FALSE;
- inLinkUpdate := FALSE;
- internal := FALSE;
- SetGenerator("WMComponents.NewComponent");
- END Init;
- PROCEDURE Write*(w : Streams.Writer;context: ANY; level : LONGINT);
- VAR enum: XMLObjects.Enumerator; c: ANY; name : Strings.String; nextLevel : LONGINT;
- BEGIN
- IF IsLocked() THEN (* D.String("Component.Write: islocked"); D.Ln; *) RETURN; END;
- IF ~internal THEN
- name := GetName();
- w.Char('<'); IF name = NIL THEN w.String("_NILNAME_") ELSE w.String(name^) END;
- WriteAttributes(w, context, level);
- w.Char('>');
- properties.WriteXML(w, context, level);
- nextLevel := level + 1;
- ELSE
- (* D.String("Component.Write: isInternal"); D.Ln; *)
- nextLevel := level;
- END;
- enum := GetContents();
- WHILE enum.HasMoreElements() DO
- c := enum.GetNext();
- IF ~(c IS WMProperties.Properties) THEN
- IF ~((c IS Component) & ((c(Component).internal) OR c(Component).IsLocked())) THEN NewLine(w, 0); NewLine(w, nextLevel); END;
- c(XML.Content).Write(w, context, nextLevel);
- (*c(Component).Write(w, context, nextLevel)*)
- END;
- END;
- IF ~internal THEN
- NewLine(w, level);
- w.String("</"); IF name = NIL THEN w.String("_NILNAME_") ELSE w.String(name^); END; w.Char('>')
- END;
- END Write;
- (*
- PROCEDURE ToRepository*(CONST repository: ARRAY OF CHAR; w: Streams.Writer; level: LONGINT);
- VAR enum: XMLObjects.Enumerator; c: ANY; name : Strings.String; nextLevel : LONGINT;
- BEGIN
- IF IsLocked() THEN RETURN; END;
- IF ~internal THEN
- name := GetName();
- w.Char('<'); IF name = NIL THEN w.String("_NILNAME_") ELSE w.String(name^) END;
- WriteAttributes(w, NIL, level);
- w.Char('>');
- properties.ToRepository(repository,w, level);
- nextLevel := level + 1;
- ELSE
- nextLevel := level;
- END;
- enum := GetContents();
- WHILE enum.HasMoreElements() DO
- c := enum.GetNext();
- IF ~(c IS WMProperties.Properties) THEN
- IF ~((c IS Component) & ((c(Component).internal) OR c(Component).IsLocked())) THEN NewLine(w, 0); NewLine(w, nextLevel); END;
- IF (c IS Repositories.Component) THEN
- c(Repositories.Component).ToRepository(repository, w, level);
- ELSE
- c(XML.Content).Write(w, NIL, nextLevel);
- END;
- END;
- END;
- IF ~internal THEN
- NewLine(w, level);
- w.String("</"); IF name = NIL THEN w.String("_NILNAME_") ELSE w.String(name^); END; w.Char('>')
- END;
- END ToRepository;
- *)
- PROCEDURE FromXML*(xml: XML.Element);
- VAR component: Component; enum: XMLObjects.Enumerator; c: ANY; element: XML.Element;
- BEGIN
- element := GetElementByName(xml,"Properties");
- IF (element = NIL) & (xml IS Component) THEN (* trick to get XML description of properties if not already there (new components) *)
- xml(Component).properties.ToXML(element)
- END;
- properties.FromXML(element);
- (* was: supercall to Repositories *)
- enum := xml.GetContents();
- WHILE enum.HasMoreElements() DO
- c := enum.GetNext();
- IF c IS XML.Element THEN
- IF ~(c IS Component) OR ~c(Component).internal THEN
- component := ComponentFromXML(c(XML.Element));
- IF component # NIL THEN
- AddContent(component)
- END;
- END;
- END;
- END;
-
- enum :=xml.GetAttributes();
- WHILE enum.HasMoreElements() DO
- c := enum.GetNext();
- IF c(XML.Attribute).GetName()^ # "generator" THEN
- SetAttributeValue(c(XML.Attribute).GetName()^, c(XML.Attribute).GetValue()^);
- END;
- END;
-
- (*Initialize;*) (* redundant *)
- END FromXML;
- PROCEDURE IsCallFromSequencer*():BOOLEAN;
- BEGIN
- ASSERT (sequencer # NIL);
- RETURN sequencer.IsCallFromSequencer()
- END IsCallFromSequencer;
- PROCEDURE AssertLock*;
- BEGIN
- ASSERT((sequencer = NIL) OR sequencer.IsCallFromSequencer() OR sequencer.lock.HasReadLock())
- END AssertLock;
- (** Atomically set the components sequencer *)
- PROCEDURE SetSequencer*(s : Messages.MsgSequencer);
- VAR old : Messages.MsgSequencer; c : XML.Content;
- BEGIN
- old := sequencer;
- IF old # NIL THEN old.lock.AcquireWrite() END;
- sequencer := s;
- c := GetFirst();
- WHILE (c # NIL) DO
- IF c IS Component THEN c(Component).SetSequencer(s); END; (*? what happens to old sequencers/active objects ?*)
- c := GetNext(c);
- END;
- IF old # NIL THEN old.lock.ReleaseWrite() END
- END SetSequencer;
- PROCEDURE Acquire*;
- BEGIN
- IF sequencer # NIL THEN sequencer.lock.AcquireWrite END
- END Acquire;
- PROCEDURE Release*;
- BEGIN
- IF sequencer # NIL THEN sequencer.lock.ReleaseWrite END
- END Release;
- PROCEDURE CheckReadLock*;
- BEGIN
- IF (sequencer # NIL) & (~sequencer.lock.HasReadLock()) THEN
- KernelLog.String("WMComponents.Component.CheckReadLock: FAILED!"); KernelLog.Ln;
- sequencer.lock.WriteLock
- END;
- IF sequencer # NIL THEN ASSERT(sequencer.lock.HasReadLock()) END
- END CheckReadLock;
- (** AddContent adds a content (element or subtree) to the element *)
- PROCEDURE AddContent*(c : XML.Content);
- VAR m:Messages.Message; rect:Rectangles.Rectangle;
- BEGIN
- ASSERT(c # NIL);
- Acquire;
- BEGIN (*{EXCLUSIVE}*)(* EXCLUSIVE leads to deadlock ?*)
- IF c IS WMProperties.Properties THEN
- properties.SetXML(c(WMProperties.Properties));
- ELSIF c IS Component THEN
- IF sequencer#NIL THEN
- c(Component).SetSequencer(sequencer);
- c(Component).Reset(SELF,NIL); (* will be scheduled by sequencer. implied RecacheProperties*)
- Initialize; (*? there is also a Initialize() within Reset() above, but that one seems sometimes not be effective because scheduled later; however ,this is partial redundancy *)
- ELSE (* no tree traversal - is less costly *)
- c(Component).initialized:=FALSE;
- c(Component).sequencer:=NIL;
- END;
- ELSIF ~(c IS XML.Comment) THEN
- Release; RETURN
- END;
- END;
- (*Acquire;*)
- AddContent^(c);
- Release;
- END AddContent;
- PROCEDURE RemoveContent*(c : XML.Content);
- BEGIN
- (*ASSERT(c # NIL);*)
- IF c = NIL THEN RETURN END;
- Acquire;
- RemoveContent^(c);
- Release;
- END RemoveContent;
- (** Add internal component. Internal components are supposed to be created and managed by its parent component.
- Internal components and their subcomponents are not externalized *)
- PROCEDURE AddInternalComponent*(component : Component);
- BEGIN
- IF (component # NIL) THEN
- component.internal := TRUE;
- AddContent(component);
- END;
- END AddInternalComponent;
- (** Return the root element of the component hierarchy. This is not necessarily the same as the
- root element of XML since it is possible to have multiple component hierarchies in an XML file *)
- PROCEDURE GetComponentRoot*(): Component;
- VAR p, c : XML.Element;
- BEGIN
- c := SELF;
- LOOP
- p := c.GetParent();
- IF (p # NIL) & (p IS Component) THEN c := p ELSE RETURN c(Component) END
- END
- END GetComponentRoot;
- PROCEDURE Find*(id : ARRAY OF CHAR) : Component;
- VAR
- root, component : Component;
- PROCEDURE IsUID(CONST id : ARRAY OF CHAR) : BOOLEAN;
- BEGIN
- RETURN id[0] = "&";
- END IsUID;
- PROCEDURE RemoveAmpersand(VAR id : ARRAY OF CHAR);
- VAR i : LONGINT;
- BEGIN
- ASSERT(id[0] = "&");
- FOR i := 0 TO LEN(id)-2 DO
- id[i] := id[i + 1];
- END;
- END RemoveAmpersand;
- BEGIN
- component := NIL;
- IF IsUID(id) THEN
- RemoveAmpersand(id);
- root := GetComponentRoot();
- component := root.FindByUID(id);
- ELSE
- component := FindByPath(id, 0);
- END;
- RETURN component;
- END Find;
- (** Find a sub component by its uid *)
- PROCEDURE FindByUID*(CONST uid : ARRAY OF CHAR) : Component;
- VAR c : XML.Content; result : Component; s : Strings.String;
- BEGIN
- IF (uid = "") THEN RETURN NIL END;
- s := SELF.uid.Get();
- IF (s # NIL) & (s^ = uid) THEN
- RETURN SELF
- ELSE
- result := NIL;
- Acquire;
- c := GetFirst();
- WHILE (result = NIL) & (c # NIL) DO
- IF (c IS Component) THEN result := c(Component).FindByUID(uid) END;
- c := GetNext(c);
- END;
- Release;
- RETURN result
- END
- END FindByUID;
- (** find a component by relative path *)
- PROCEDURE FindByPath*(CONST path : ARRAY OF CHAR; pos : LONGINT) : Component;
- VAR component : Component;
- BEGIN
- Acquire;
- component := FindRelativePath(SELF, path, pos);
- Release;
- RETURN component;
- END FindByPath;
- PROCEDURE StringToComponent*(str : Strings.String) : Component;
- VAR
- id : ARRAY 100 OF CHAR;
- isUID : BOOLEAN;
- ch : CHAR;
- sr : Streams.StringReader;
- r, target : Component;
- BEGIN
- NEW(sr, LEN(str)); sr.Set(str^);
- isUID := FALSE; IF sr.Peek() = "%" THEN isUID := TRUE; ch := sr.Get() END;
- sr.Token(id);
- IF isUID THEN r := GetComponentRoot(); target := r.FindByUID(id);
- IF target = NIL THEN KernelLog.String("StringToComponent : UID target not found: "); KernelLog.String(id); KernelLog.Ln; END
- ELSE target := FindByPath(id, 0);
- IF target = NIL THEN KernelLog.String("StringToComponent : Path target not found: "); KernelLog.String(id); KernelLog.Ln; END
- END;
- RETURN target
- END StringToComponent;
- (** Search a CompCommand by string *)
- PROCEDURE StringToCompCommand*(eventstr : Strings.String) : WMEvents.EventListener;
- VAR
- id, name : ARRAY 100 OF CHAR;
- isUID : BOOLEAN;
- ch : CHAR;
- sr : Streams.StringReader;
- r, target : Component;
- BEGIN
- NEW(sr, LEN(eventstr)); sr.Set(eventstr^);
- isUID := FALSE; IF sr.Peek() = "%" THEN isUID := TRUE; ch := sr.Get() END;
- sr.Token(id); sr.SkipWhitespace; sr.Token(name);
- IF isUID THEN r := GetComponentRoot(); target := r.FindByUID(id);
- IF target = NIL THEN KernelLog.String("StringToEvent : UID target not found: "); KernelLog.String(id); KernelLog.Ln; END
- ELSE target := FindByPath(id, 0);
- IF target = NIL THEN KernelLog.String("StringToEvent : Path target not found: "); KernelLog.String(id); KernelLog.Ln; END
- END;
- IF target # NIL THEN RETURN target.eventListeners.GetHandlerByName(NewString(name))
- ELSE RETURN NIL
- END
- END StringToCompCommand;
- (** The Finalize Method is asynchronous since queuing could result in modules being freed before finalize ispropagated..
- Active components should terminate, external resources should be released *)
- PROCEDURE Finalize*; (** PROTECTED *)
- VAR c : XML.Content;
- BEGIN
- IF TraceFinalize IN Trace THEN IF uid # NIL THEN (* KernelLog.String(uid.string) *) KernelLog.String(".Finalize") END END;
- Acquire;
- c := GetFirst();
- WHILE (c # NIL) DO
- IF (c IS Component) THEN c(Component).Finalize END;
- c := GetNext(c);
- END;
- properties.Finalize;
- Release;
- END Finalize;
- (* reset/initialize a hierarchy of components *)
- PROCEDURE Reset*(sender, data : ANY); (** PROTECTED *)
- VAR c : XML.Content;
- BEGIN
- IF ~IsCallFromSequencer() THEN
- sequencer.ScheduleEvent(SELF.Reset, sender, data);
- IF CanYield THEN Objects.Yield END;
- ELSE
- BEGIN (* how about exclusivity ?*)
- RecacheProperties;
- c := GetFirst();
- WHILE (c # NIL) DO
- IF c IS Component THEN
- c(Component).Reset(sender, data)
- END;
- c := GetNext(c);
- END;
- IF ~initialized THEN Initialize END;
- END;
- END
- END Reset;
- (* Initialize is called by Reset() and is required to render components responsive *)
- PROCEDURE Initialize*; (** PROTECTED *)
- BEGIN
- BEGIN{EXCLUSIVE}
- initialized := TRUE
- END;
- END Initialize;
- (** Internal interface of the message handler. This method may only be called via the Handle method.
- Components that need to handle messages should implement HandleInternal. *)
- PROCEDURE HandleInternal*(VAR msg : Messages.Message); (** PROTECTED *)
- VAR pa : WMProperties.PropertyArray; i : LONGINT;
- BEGIN
- ASSERT(IsCallFromSequencer());
- IF (msg.msgType = Messages.MsgSetLanguage) & (msg.ext # NIL) & (msg.ext IS LanguageExtension) THEN
- pa := properties.Enumerate();
- IF (pa # NIL) THEN
- FOR i := 0 TO LEN(pa) - 1 DO
- IF (pa[i] # NIL) & (pa[i] IS WMProperties.StringProperty) THEN
- pa[i](WMProperties.StringProperty).SetLanguage(msg.ext(LanguageExtension).languages);
- END;
- END;
- END;
- LanguageChanged(msg.ext(LanguageExtension).languages);
- BroadcastSubcomponents(msg);
- END;
- END HandleInternal;
- (** External interface to the message handler. Asynchronous messages are synchronized by
- the sequencer of the Container *)
- PROCEDURE Handle*(VAR msg : Messages.Message); (** FINAL *)
- VAR s : Strings.String;
- BEGIN
- (* if asynchronous call --> synchronize *)
- IF sequencer=NIL THEN RETURN
- ELSIF ~IsCallFromSequencer() THEN
- IF ~sequencer.Add(msg) THEN
- s := uid.Get();
- KernelLog.String("A message sent to ");
- IF s # NIL THEN KernelLog.String(s^) ELSE KernelLog.String(" <uid = NIL>") END;
- KernelLog.String(" was discarded")
- END;
- IF CanYield THEN Objects.Yield END (* give the sequencer an immediate chance to react -- important on single-processor machines *)
- ELSE HandleInternal(msg) END
- END Handle;
- (** Broadcast a message to all direct subcomponents. The subcomponent can then decide
- whether to further propagate the message to its children or not *)
- PROCEDURE BroadcastSubcomponents*(VAR msg : Messages.Message); (** FINAL *)
- VAR c : XML.Content;
- BEGIN
- Acquire;
- c := GetFirst();
- WHILE (c # NIL) DO
- IF c IS Component THEN c(Component).Handle(msg) END;
- c := GetNext(c);
- END;
- Release
- END BroadcastSubcomponents;
- (* not to be called from user *)
- PROCEDURE LanguageChanged*(languages : Localization.Languages);
- BEGIN
- ASSERT(languages # NIL);
- ASSERT(IsCallFromSequencer());
- END LanguageChanged;
- (* LinkChanged can be called to inform about changes of the state of links (i.e. objects in reference properties)
- Unlike PropertyChanged which informs about an actual replacement of the link *)
- PROCEDURE LinkChanged*(sender, link: ANY);
- BEGIN ASSERT(IsCallFromSequencer());
- END LinkChanged;
- (* will be called synchronously if a property of the component changes. May not be called directly.
- Call Invalidate in this procedure whenever a property changed that impacts the visualization.
- No such messages are sent until the component is initialized *)
- PROCEDURE PropertyChanged*(sender, property : ANY);(** PROTECTED *)
- BEGIN ASSERT(IsCallFromSequencer());
- END PropertyChanged;
- (** called by the internal property changed handler via the sequencer, either if multiple properties have
- changed or a Reset occured. The PropertyChanged method is called, too in case of multi-property changes
- The component should call the inherited RecacheProperties method.
- Do not call Invalidate in RecacheProperties, but rather in PropertyChanged(). *)
- PROCEDURE RecacheProperties*;
- BEGIN
- END RecacheProperties;
- PROCEDURE InternalPropertyChanged(sender, property : ANY);
- BEGIN
- IF ~initialized THEN RETURN END;
- IF ~IsCallFromSequencer() THEN
- sequencer.ScheduleEvent(SELF.InternalPropertyChanged, sender, property);
- IF CanYield THEN Objects.Yield END;
- ELSE
- IF ~inPropertyUpdate THEN
- inPropertyUpdate := TRUE;
- IF property = properties THEN RecacheProperties END;
- PropertyChanged(sender, property);
- inPropertyUpdate := FALSE
- END;
- END
- END InternalPropertyChanged;
- PROCEDURE InternalLinkChanged(sender, link : ANY);
- BEGIN
- IF ~initialized THEN RETURN END;
- IF ~IsCallFromSequencer() THEN
- sequencer.ScheduleEvent(SELF.InternalLinkChanged, sender, link);
- IF CanYield THEN Objects.Yield END;
- ELSE
- IF ~inLinkUpdate THEN
- inLinkUpdate := TRUE;
- LinkChanged(sender, link);
- inLinkUpdate := FALSE
- END;
- END
- END InternalLinkChanged;
- END Component;
- TYPE
- Macro* = ARRAY 128 OF CHAR;
- (** Installable macro handler procedure. {(originator # NIL) & (w # NIL)} *)
- MacroHandlerProcedure* = PROCEDURE {DELEGATE} (CONST macro : Macro; originator : Component; w : Streams.Writer; VAR handled : BOOLEAN);
- Namespace = ARRAY 16 OF CHAR;
- MacroHandler = POINTER TO RECORD
- handler : MacroHandlerProcedure;
- namespace : Namespace;
- next : MacroHandler;
- END;
- TYPE
- (** Basic visual component *)
- VisualComponent* = OBJECT(Component)
- VAR
- bounds-, bearing-, relativeBounds-: WMProperties.RectangleProperty;
- alignment- : WMProperties.Int32Property;
- fillColor- : WMProperties.ColorProperty;
- font- : WMProperties.FontProperty;
- scaleFont-: WMProperties.Int32Property;
- visible-, takesFocus-, needsTab-, editMode- : WMProperties.BooleanProperty;
- focusPrevious-, focusNext- : WMProperties.StringProperty;
- model- : WMProperties.ReferenceProperty;
- onStartDrag- : WMEvents.EventSource;
- canvasState- : WMGraphics.CanvasState; (** PROTECTED *)
- fPointerOwner : VisualComponent;
- hasFocus- : BOOLEAN;
- focusComponent : VisualComponent; (** Subcomponent that has the keyboard focus, if any *)
- extPointerDown, extPointerUp, extPointerMove : PointerHandler;
- extPointerLeave : PointerLeaveHandler;
- extDragOver, extDragDropped : DragDropHandler;
- extDragResult : DragResultHandler;
- extKeyEvent : KeyEventHandler;
- extDraw : DrawHandler;
- extFocus : FocusHandler;
- extContextMenu : ContextMenuHandler;
- extGetPositionOwner : GetPositionOwnerHandler;
- layoutManager : LayoutManager;
- aligning* : BOOLEAN;
- pointerInfo : WM.PointerInfo;
- editRegion: LONGINT;
- editX, editY: LONGINT;
- keyFlags: SET; (*! remove *)
- oldPointerInfo : WM.PointerInfo;
- PROCEDURE &Init*;
- BEGIN
- Init^;
- SetGenerator("WMComponents.NewVisualComponent");
- SetNameAsString(StrVisualComponent);
- NEW(bounds, PrototypeBounds, NIL, NIL); properties.Add(bounds);
- NEW(relativeBounds, PrototypeBoundsRelative, NIL, NIL); properties.Add(relativeBounds);
- NEW(bearing, PrototypeBearing, NIL, NIL); properties.Add(bearing);
- NEW(alignment, PrototypeAlignment, NIL, NIL); properties.Add(alignment);
- NEW(fillColor, PrototypeFillColor, NIL, NIL); properties.Add(fillColor);
- NEW(visible, PrototypeVisible, NIL, NIL); properties.Add(visible);
- NEW(takesFocus, PrototypeTakesFocus, NIL, NIL); properties.Add(takesFocus);
- NEW(needsTab, PrototypeNeedsTab, NIL, NIL); properties.Add(needsTab);
- NEW(focusPrevious, PrototypeFocusPrevious, NIL, NIL); properties.Add(focusPrevious);
- NEW(focusNext, PrototypeFocusNext, NIL, NIL); properties.Add(focusNext);
- NEW(editMode, PrototypeEditMode, NIL,NIL); properties.Add(editMode); editMode.Set(FALSE);
- NEW(model, ModelPrototype, NIL, NIL); properties.Add(model);
- NEW(font, PrototypeFont, NIL, NIL); properties.Add(font);
- NEW(scaleFont, PrototypeScaleFont, NIL,NIL); properties.Add(scaleFont);
- NEW(onStartDrag, SELF, GSonStartDrag,GSonStartDragInfo, SELF.StringToCompCommand);
- events.Add(onStartDrag);
- extGetPositionOwner := NIL;
- aligning := FALSE; fPointerOwner := SELF; focusComponent := SELF;
- END Init;
- (** Focus handling *)
- PROCEDURE TraceFocusChain*;
- BEGIN
- KernelLog.String(" -> ");
- ShowComponent(SELF);
- IF focusComponent = SELF THEN
- KernelLog.String(" <END>"); KernelLog.Ln;
- ELSIF focusComponent = NIL THEN
- KernelLog.String("ERROR focusComponent is NIL"); KernelLog.Ln;
- ELSE
- focusComponent.TraceFocusChain;
- END;
- END TraceFocusChain;
- (** Set the keyboard focus chain to this component its takesFocus field is set and unset the old chain *)
- PROCEDURE SetFocus*;
- VAR root, vc : VisualComponent; p : XML.Element;
- BEGIN
- Acquire;
- IF (takesFocus.Get() OR editMode.Get()) & visible.Get() THEN
- IF TraceFocus IN Trace THEN KernelLog.String("Set focus to: "); ShowComponent(SELF); KernelLog.Ln; END;
- root := GetVisualComponentRoot();
- IF (root IS Form) THEN root(Form).lastFocusComponent := SELF; END;
- (* unset the old focus chain *)
- (* find the leaf component that has the focus *)
- vc := root;
- WHILE (vc # NIL) & (vc.focusComponent # NIL) & (vc.focusComponent # vc) DO vc := vc.focusComponent; END;
- (* clear the focus chain until the root or this component *)
- p := vc;
- WHILE (p # SELF) & (p # NIL) & (p IS VisualComponent) DO
- vc := p(VisualComponent);
- vc.focusComponent := vc;
- vc.FocusLost;
- IF (vc.extFocus # NIL) THEN vc.extFocus(FALSE); END;
- p := p.GetParent();
- END;
- (* set the new chain *)
- vc := SELF; vc.focusComponent := SELF;
- WHILE (vc # NIL) DO
- IF ~vc.hasFocus THEN
- vc.FocusReceived;
- IF vc.extFocus # NIL THEN vc.extFocus(TRUE) END;
- END;
- p := vc.GetParent();
- IF (p # NIL) & (p IS VisualComponent) THEN
- p(VisualComponent).focusComponent := vc; vc := p(VisualComponent);
- ELSE
- vc := NIL;
- END;
- END;
- ELSE (* component does not take focus or is not visible *)
- IF TraceFocus IN Trace THEN ShowComponent(SELF); KernelLog.String("does not take focus."); KernelLog.Ln END;
- END;
- Release;
- END SetFocus;
- PROCEDURE FocusReceived*;
- BEGIN
- hasFocus := TRUE
- END FocusReceived;
- PROCEDURE FocusLost*;
- BEGIN
- hasFocus := FALSE
- END FocusLost;
- PROCEDURE SetFocusTo(CONST id : ARRAY OF CHAR);
- VAR vc : Component;
- BEGIN
- vc := Find(id);
- IF (vc # NIL) & (vc IS VisualComponent) THEN
- vc(VisualComponent).SetFocus;
- ELSE
- KernelLog.String("Warning: WMComponents.VisualComponent.SetFocusTo: Component ");
- KernelLog.String(id); KernelLog.String(" not found."); KernelLog.Ln;
- END;
- END SetFocusTo;
- PROCEDURE FocusNext*;
- VAR string : Strings.String;
- BEGIN
- string := focusNext.Get();
- IF (string # NIL) THEN
- SetFocusTo(string^);
- END;
- END FocusNext;
- PROCEDURE FocusPrev*;
- VAR string : Strings.String;
- BEGIN
- string := focusPrevious.Get();
- IF (string # NIL) THEN
- SetFocusTo(string^);
- END;
- END FocusPrev;
- (* LinkChanged can be called to inform about changes of the state of links (i.e. objects in reference properties)
- Unlike PropertyChanged which informs about an actual replacement of the link *)
- PROCEDURE LinkChanged*(sender, link: ANY);
- BEGIN
- IF sender = model THEN
- Invalidate
- END;
- END LinkChanged;
- PROCEDURE PropertyChanged*(sender, property : ANY);
- BEGIN
- IF property = bounds THEN
- (*ScaleFont(bounds.GetHeight(), scaleFont.Get());*)
- Resized (*implicit Invalidate*)
- ELSIF property = bearing THEN Resized;
- (* ELSIF bounds=relativeBounds THEN ? *)
- ELSIF property = alignment THEN AlignmentChanged; Invalidate (*moved here from implicit Invalidate*)
- ELSIF property = fillColor THEN Invalidate;
- ELSIF property = font THEN
- IF scaleFont.Get() # 0 THEN
- ScaleFont(bounds.GetHeight(), scaleFont.Get()); (* implicit Invalidate*)
- END;
- Invalidate;
- ELSIF (property = scaleFont) THEN ScaleFont(bounds.GetHeight(),scaleFont.Get()); (*implicit Invalidate*)
- ELSIF property = visible THEN Resized (*Implicit Invalidate*)
- (* ELSIF takesFocus, needsTab...*)
- ELSIF property = editMode THEN Invalidate;
- ELSIF property = model THEN LinkChanged(model, model.Get());
- ELSE PropertyChanged^(sender, property)
- END;
- END PropertyChanged;
- PROCEDURE RecacheProperties;
- BEGIN
- RecacheProperties^;
- IF scaleFont.Get() # 0 THEN ScaleFont(bounds.GetHeight(), scaleFont.Get()) END;
- IF (model # NIL) & (model.Get() # NIL) THEN LinkChanged(model,model.Get()) END;
- END RecacheProperties;
- (** Get the root of visible components. Not neccessarily the same as GetComponentRoot() OR GetRoot() *)
- PROCEDURE GetVisualComponentRoot*(): VisualComponent;
- VAR p, c : XML.Element;
- BEGIN
- c := SELF;
- LOOP
- p := c.GetParent();
- IF (p # NIL) & (p IS VisualComponent) THEN c := p
- ELSE RETURN c(VisualComponent)
- END
- END
- END GetVisualComponentRoot;
- PROCEDURE AdaptRelativeBounds(inner: Rectangles.Rectangle; parent: XML.Element);
- VAR outer: Rectangles.Rectangle;
- BEGIN
- Acquire;
- IF (parent # NIL) & (parent IS VisualComponent) THEN
- (* inner := bounds.Get();*)
- outer := parent(VisualComponent).bounds.Get();
- IF (outer.b - outer.t > 0) & (outer.r - outer.l > 0) THEN
- relativeBounds.Set(Rectangles.MakeRect( (inner.l * MaxRel) DIV (outer.r-outer.l), (inner.t * MaxRel) DIV (outer.b-outer.t),
- (inner.r * MaxRel) DIV (outer.r - outer.l), (inner.b * MaxRel) DIV (outer.b - outer.t)));
- END;
- END;
- Release
- END AdaptRelativeBounds;
- (** Position handling *)
- PROCEDURE AlignmentChanged;
- VAR p : XML.Element; inner, outer: Rectangles.Rectangle;
- BEGIN
- Acquire;
- IF alignment.Get()= AlignRelative THEN
- AdaptRelativeBounds(bounds.Get(), GetParent());
- END;
- p := SELF.GetParent();
- IF (p # NIL) & (p IS VisualComponent) THEN
- p(VisualComponent).AlignSubComponents
- END;
- (*Invalidate;*)
- Release
- END AlignmentChanged;
- (** Get the bounds of the component *)
- PROCEDURE GetClientRect*() : Rectangles.Rectangle;
- VAR r, t : Rectangles.Rectangle;
- BEGIN
- r := bounds.Get();
- t := Rectangles.MakeRect(0, 0, r.r - r.l, r.b - r.t);
- RETURN t
- END GetClientRect;
- PROCEDURE SetLayoutManager*(layoutManager : LayoutManager);
- BEGIN
- Acquire;
- SELF.layoutManager := layoutManager;
- Release
- END SetLayoutManager;
- PROCEDURE AlignEvent(sender, data: ANY);
- BEGIN
- AlignSubComponents;
- END AlignEvent;
- PROCEDURE AlignSubComponents*;
- VAR c : XML.Content; vc : VisualComponent;
- r, b, rel : Rectangles.Rectangle;
- BEGIN
- Acquire;
- IF (sequencer # NIL) & ~IsCallFromSequencer() THEN sequencer.ScheduleEvent(SELF.AlignEvent, NIL,NIL); Release; RETURN
- ELSIF sequencer = NIL THEN Release; RETURN
- END;
- IF aligning THEN Release; RETURN END;
- DisableUpdate;
- aligning := TRUE;
- IF layoutManager # NIL THEN layoutManager(SELF)
- ELSE
- r := GetClientRect();
- c := GetFirst();
- WHILE (c # NIL) DO
- IF c IS VisualComponent THEN
- vc := c(VisualComponent);
- IF vc.visible.Get() THEN
- b := vc.bearing.Get();
- CASE vc.alignment.Get() OF
- | AlignTop : vc.bounds.Set(Rectangles.MakeRect(r.l + b.l , r.t + b.t, r.r - b.r, r.t + b.t + vc.bounds.GetHeight())); INC(r.t, vc.bounds.GetHeight() + b.t + b.b)
- | AlignLeft : vc.bounds.Set(Rectangles.MakeRect(r.l + b.l, r.t + b.t, r.l + b.l + vc.bounds.GetWidth(), r.b - b.b)); INC(r.l, vc.bounds.GetWidth() + b.l + b.r)
- | AlignBottom : vc.bounds.Set(Rectangles.MakeRect(r.l + b.l, r.b - vc.bounds.GetHeight() - b.b, r.r - b.r, r.b - b.b)); DEC(r.b, vc.bounds.GetHeight() + b.t + b.b)
- | AlignRight : vc.bounds.Set(Rectangles.MakeRect(r.r - vc.bounds.GetWidth() - b.r , r.t + b.t, r.r - b.r, r.b - b.b)); DEC(r.r, vc.bounds.GetWidth() + b.l + b.r);
- | AlignClient : IF ~Rectangles.RectEmpty(r) THEN vc.bounds.Set(Rectangles.MakeRect(r.l + b.l , r.t + b.t, r.r - b.r, r.b - b.b)) END
- | AlignRelative:
- IF ~editMode.Get() THEN
- rel := vc.relativeBounds.Get();
- vc.bounds.Set(Rectangles.MakeRect(r.l + ((r.r-r.l)*rel.l+MaxRel DIV 2) DIV MaxRel, r.t + ((r.b-r.t)*rel.t+MaxRel DIV 2) DIV MaxRel,
- r.l + ((r.r-r.l)*rel.r +MaxRel DIV 2) DIV MaxRel, r.t+((r.b-r.t)*rel.b + MaxRel DIV 2) DIV MaxRel));
- ELSE
- vc.AdaptRelativeBounds(vc.bounds.Get(),SELF);
- END;
- ELSE (* nothing *)
- END;
- END;
- END;
- c := GetNext(c);
- END;
- END;
- EnableUpdate;
- aligning := FALSE;
- Release;
- END AlignSubComponents;
- PROCEDURE Initialize*;
- BEGIN
- Initialize^;
- AlignSubComponents;
- IF sequencer#NIL THEN Invalidate END;
- END Initialize;
- (** Locating *)
- (** transform the local component coordinates into global window manager coordinates *)
- PROCEDURE ToWMCoordinates*(x, y : LONGINT; VAR gx, gy : LONGINT);
- VAR cr : Component; tc : XML.Element; r : Rectangles.Rectangle;
- BEGIN
- gx := x; gy := y; tc := SELF;
- REPEAT
- IF (tc # NIL) & (tc IS VisualComponent) THEN
- r := tc(VisualComponent).bounds.Get();
- INC(gx, r.l); INC(gy, r.t)
- END;
- tc := tc.GetParent()
- UNTIL (tc = NIL) OR ~(tc IS VisualComponent);
- cr := GetComponentRoot();
- IF (cr # NIL) & (cr IS Form) THEN
- INC(gx, cr(Form).window.bounds.l);
- INC(gy, cr(Form).window.bounds.t)
- END
- END ToWMCoordinates;
- (** Return if the component is hit at (x, y) in component coordinates *)
- PROCEDURE IsHit*(x, y: LONGINT): BOOLEAN;
- BEGIN
- RETURN visible.Get() & enabled.Get() & Rectangles.PointInRect(x, y, GetClientRect())
- END IsHit;
- (** Return the topmost first child component at (x, y) *)
- PROCEDURE GetPositionOwner*(x, y: LONGINT): VisualComponent;
- VAR c: XML.Content; result, vc : VisualComponent; r : Rectangles.Rectangle;
- BEGIN
- Acquire;
- result := SELF;
- c := GetFirst();
- WHILE (c # NIL) DO
- IF c IS VisualComponent THEN
- vc := c(VisualComponent);
- r := vc.bounds.Get();
- IF Rectangles.PointInRect(x, y, r) & vc.IsHit(x - r.l, y - r.t) THEN
- result := vc
- END;
- END;
- c := GetNext(c);
- END;
- Release;
- RETURN result
- END GetPositionOwner;
- (** DragOver is called via the message handler. The should call manager.SetDragAccept(SELF, .... *)
- PROCEDURE DragOver*(x, y: LONGINT; dragInfo : WM.DragInfo);
- END DragOver;
- (** Dropped is called via the message handler to indicate an item has been dropped. *)
- PROCEDURE DragDropped*(x, y: LONGINT; dragInfo : WM.DragInfo);
- BEGIN
- IF dragInfo.onReject # NIL THEN dragInfo.onReject(SELF,dragInfo) END;
- END DragDropped;
- (*
- PROCEDURE EditDragOver(x,y: LONGINT; dragInfo: WMWindowManager.DragInfo);
- BEGIN
- END EditDragOver;
- *)
- PROCEDURE FromXML(xml: XML.Element);
- BEGIN
- FromXML^(xml);
- END FromXML;
- (*
- PROCEDURE AddContent*(c : XML.Content);
- VAR m:Messages.Message;
- BEGIN
- AddContent^(c);
- IF c IS VisualComponent THEN
- m.sender:=SELF (*c*); (*move to VisualComponent ?*)
- m.msgType := Messages.MsgInvalidate;
- m.msgSubType := Messages.MsgSubAll;
- (* SELF(VisualComponent).Invalidate ...*)
- IF sequencer.Add(m) THEN END;
- END;
- END AddContent;
- *)
- PROCEDURE AddVisualComponent(c :VisualComponent; x, y : LONGINT);
- VAR bounds : Rectangles.Rectangle;canvas: WMGraphics.BufferCanvas; relativeAlignment: BOOLEAN;
- BEGIN
- ASSERT(c # NIL);
-
- IF (c.bounds.GetWidth() < 10) OR (c.bounds.GetHeight() < 10) THEN
- c.bounds.SetExtents(40, 20);
- END;
- bounds := c.bounds.Get();
- Rectangles.MoveRel(bounds, x, y);
- c.bounds.Set(bounds);
- c.AdaptRelativeBounds(c.bounds.Get(), SELF);
- (*
- IF c.sequencer # sequencer THEN c.SetSequencer(sequencer) END; (* redundant - implicit in AddContent *)
- c.Reset(NIL, NIL); (*currently redundant - already in happens Component.AddContent() *)
- c.RecacheProperties; (*currently redundant - already in happens Reset() *)
- *)
- Acquire;
- AddContent(c);
- Release;
- END AddVisualComponent;
-
- PROCEDURE EditDragDropped(x,y: LONGINT; dragInfo: WM.DragInfo): BOOLEAN;
- VAR data: ANY; e: ComponentListEntry; parent: XML.Element; dt: DropTarget; pos: LONGINT;
- BEGIN
- data := dragInfo.data;
- IF (data # NIL) & (data IS VisualComponent) THEN
- IF dragInfo.sender # SELF THEN
- IF dragInfo.onAccept # NIL THEN dragInfo.onAccept(SELF,dragInfo) END;
- data(VisualComponent).bounds.Set(Rectangles.MakeRect(0, 0, data(VisualComponent).bounds.GetWidth(), data(VisualComponent).bounds.GetHeight()));
- AddVisualComponent(data(VisualComponent),x+dragInfo.offsetX,y+dragInfo.offsetY);
- Invalidate;
- ELSE
- parent := GetParent();
- IF parent = NIL THEN RETURN FALSE END;
- x := x + bounds.GetLeft();
- y := y + bounds.GetTop();
- RETURN parent(VisualComponent).EditDragDropped(x,y,dragInfo);
- END;
- RETURN TRUE
- ELSIF (data # NIL) & (data IS Repositories.Component) THEN
- IF dragInfo.onAccept # NIL THEN dragInfo.onAccept(SELF,dragInfo) END;
- model.Set(data(Repositories.Component));
- RETURN TRUE
- ELSIF (data # NIL) & (data IS SelectionList) THEN
- IF (dragInfo.sender # SELF) & ~data(SelectionList).Has(SELF) THEN
- IF dragInfo.onAccept # NIL THEN dragInfo.onAccept(SELF,dragInfo) END;
- e := data(SelectionList).first;
- WHILE e # NIL DO
- e.component.bounds.Set(Rectangles.MakeRect(0, 0, e.component.bounds.GetWidth(), e.component.bounds.GetHeight()));
- ASSERT(e.component IS VisualComponent);
- AddVisualComponent(e.component,x+e.dx+dragInfo.offsetX, y+e.dy + dragInfo.offsetY);
- e := e.next;
- END;
- Invalidate;
- ELSE
- parent := GetParent();
- IF parent = NIL THEN RETURN FALSE END;
- x := x + bounds.GetLeft();
- y := y + bounds.GetTop();
- RETURN parent(VisualComponent).EditDragDropped(x,y,dragInfo);
- END;
- RETURN TRUE
- ELSE
- NEW(dt, SELF, SetDroppedString, x,y);
- dragInfo.data := dt;
- ConfirmDrag(TRUE, dragInfo);
- RETURN FALSE
- END;
- END EditDragDropped;
- PROCEDURE SetDroppedString( CONST string : ARRAY OF CHAR; x,y : LONGINT; VAR res : LONGINT);
- VAR gen: XML.GeneratorProcedure; moduleName, procedureName ,msg: Modules.Name; element: XML.Element;
- context: Repositories.Context; repositoryName, componentName: ARRAY 265 OF CHAR; componentID: LONGINT; object: Repositories.Component;
- BEGIN
- Commands.Split(string, moduleName, procedureName, res, msg);
- IF (res = Commands.Ok) THEN
- GETPROCEDURE(moduleName, procedureName, gen);
- END;
- IF gen # NIL THEN
- element := gen();
- ELSIF Repositories.IsCommandString(string) THEN
- Repositories.CallCommand(string, context, res);
- IF (res = Repositories.Ok) & (context.object # NIL) & (context.object IS Repositories.Component) THEN
- element := context.object(Repositories.Component);
- END;
- ELSIF Repositories.SplitName(string, repositoryName, componentName, componentID) THEN
- Repositories.GetComponent(repositoryName, componentName, componentID, object, res);
- element := object;
- END;
- IF (element # NIL) & (element IS VisualComponent) THEN
- AddVisualComponent(element(VisualComponent),x,y);
- Invalidate;
- ELSIF (element # NIL) & (element IS Repositories.Component) THEN
- model.Set(element(Repositories.Component))
- END;
- res := 1; (* to avoid removal of source *)
- END SetDroppedString;
- (** Is called via the message handler to inform about the result of a recent drag operation *)
- PROCEDURE DragResult*(accepted : BOOLEAN; recipient : ANY; dragInfo : WM.DragInfo);
- END DragResult;
- (** Start a drag operation. *)
- PROCEDURE StartDrag*(data : ANY; img : WMGraphics.Image; offsetX, offsetY: LONGINT; onAccept, onReject : Messages.CompCommand) : BOOLEAN;
- VAR rc : Component;
- BEGIN
- rc := GetVisualComponentRoot();
- IF (rc # NIL) & (rc IS Form) THEN
- RETURN rc(Form).window.StartDrag(SELF, data, img, offsetX, offsetY, onAccept, onReject)
- ELSE
- RETURN FALSE
- END
- END StartDrag;
- (** confirm a drag operation. *)
- PROCEDURE ConfirmDrag*(accept : BOOLEAN; dragInfo : WM.DragInfo);
- VAR rc : Component;
- BEGIN
- rc := GetVisualComponentRoot();
- IF (rc # NIL) & (rc IS Form) THEN rc(Form).window.ConfirmDrag(accept, dragInfo)
- END
- END ConfirmDrag;
- (** Is called by the component if it detects a default drag action. The subclass should then call StartDrag with
- the respective coordinates. If it wants to start the drag operation *)
- PROCEDURE AutoStartDrag*;
- BEGIN
- onStartDrag.Call(NIL)
- END AutoStartDrag;
- (** Is called by the component if it detects a request for a context menu. The subclass should open the
- context menu if applicable *)
- PROCEDURE ShowContextMenu*(x, y : LONGINT);
- BEGIN
- IF extContextMenu # NIL THEN extContextMenu(SELF, x, y) END;
- END ShowContextMenu;
- (** Special methods *)
- PROCEDURE Resized*;
- VAR p : XML.Element;
- BEGIN
- (*
- AdaptRelativeBounds(GetParent());
- *)
- IF sequencer # NIL THEN ASSERT(sequencer.lock.HasWriteLock()) END;
- DisableUpdate;
- p := SELF.GetParent();
- IF (p # NIL) & (p IS VisualComponent) & (alignment.Get() # AlignNone) THEN p(VisualComponent).AlignSubComponents END;
- IF visible.Get() THEN
- AlignSubComponents;
- IF scaleFont.Get() # 0 THEN ScaleFont(bounds.GetHeight(), scaleFont.Get()) END;
- END;
- EnableUpdate;
- IF (p # NIL) & (p IS VisualComponent) THEN p(VisualComponent).Invalidate
- ELSE Invalidate()
- END
- END Resized;
- (** Is called before any sub-components are drawn *)
- PROCEDURE DrawBackground*(canvas : WMGraphics.Canvas);
- VAR color,i : LONGINT; name:Strings.String;
- (* DebugUpdates can be used in order to visualize updates via some color cycling
- Moreover, it slows down display extremely such that updates can be seen
- *)
- CONST DebugUpdates = FALSE;
- BEGIN
- (* message tracing
- IF sequencer = Messages.debug THEN
- D.Enter;
- D.Ln;
- D.String("##############"); D.Ln;
- name := GetName();
- IF name # NIL THEN D.String(name^); D.Ln; END;
- name := id.Get();
- IF name # NIL THEN D.String(name^); D.Ln; END;
- D.Int(Kernel.GetTicks(),1); D.Ln;
- (*D.TraceBack;*)
- D.Exit;
- END;
- *)
- CheckReadLock;
-
- IF DebugUpdates THEN
- canvas.Fill(GetClientRect(), Kernel.GetTicks()*100H +0FFH, WMGraphics.ModeSrcOverDst);
- FOR i := 0 TO 10000000 DO END;
- ELSE
- color := fillColor.Get();
- IF color # 0 THEN canvas.Fill(GetClientRect(), color, WMGraphics.ModeSrcOverDst) END;
- END;
- END DrawBackground;
- (** Is called after all sub-components are drawn *)
- PROCEDURE DrawForeground*(canvas : WMGraphics.Canvas);
- END DrawForeground;
- PROCEDURE DrawSelection(canvas : WMGraphics.Canvas);
- VAR r,r0: Rectangles.Rectangle; x,y,x0,y0: LONGINT; color: LONGINT;
- PROCEDURE MarkSelected(r: Rectangles.Rectangle; w, color: LONGINT);
- VAR r0: Rectangles.Rectangle;
- BEGIN
- r0 :=r; r0.r := r.l+w; r0.b := r.t+w;
- canvas.Fill(r0, color, WMGraphics.ModeSrcOverDst);
- r0 :=r; r0.r := r.l+w; r0.t := r.b-w;
- canvas.Fill(r0, color, WMGraphics.ModeSrcOverDst);
- r0 :=r; r0.l := r.r-w; r0.b := r.t+w;
- canvas.Fill(r0, color, WMGraphics.ModeSrcOverDst);
- r0 :=r; r0.l := r.r-w; r0.t := r.b-w;
- canvas.Fill(r0, color, WMGraphics.ModeSrcOverDst);
- r0 := r; r0.l := r.r-1; canvas.Fill(r0,color, WMGraphics.ModeSrcOverDst);
- r0 := r; r0.r := r.l+1; canvas.Fill(r0,color, WMGraphics.ModeSrcOverDst);
- r0 := r; r0.b := r.t+1; canvas.Fill(r0,color, WMGraphics.ModeSrcOverDst);
- r0 := r; r0.t := r.b-1; canvas.Fill(r0,color, WMGraphics.ModeSrcOverDst);
- END MarkSelected;
- BEGIN
- CheckReadLock;
- r := GetClientRect();
- IF editMode.Get() THEN
- y := r.t + (-r.t) MOD 8;
- y0 := 0;
- WHILE y < r.b DO
- r0.t := y; r0.b := y+2;
- x := r.l + (-r.l) MOD 8; x0 := 0;
- WHILE x < r.r DO
- r0.l := x; r0.r := x+2;
- IF ODD(x DIV 8+y DIV 8) THEN color := 060H;
- ELSE color := LONGINT(0FFFFFF60H);
- END;
- canvas.Fill(r0,color, WMGraphics.ModeSrcOverDst);
- INC(x,8); INC(x0);
- END;
- INC(y,8);INC(y0);
- END;
- END;
- IF selection.Has(SELF) THEN
- IF selection.state = 0 THEN
- MarkSelected(r,8,LONGINT(080H));
- ELSE
- MarkSelected(r,8,LONGINT(0FFFFFFFF80H));
- END;
- END;
- END DrawSelection;
- PROCEDURE DrawSubComponents*(canvas : WMGraphics.Canvas);
- VAR c : XML.Content; vc : VisualComponent; cr, r : Rectangles.Rectangle;
- BEGIN
- CheckReadLock;
- canvas.GetClipRect(cr);
- canvas.SaveState(canvasState);
- (* draw all sub-components *)
- c := GetFirst();
- WHILE (c # NIL) DO
- IF c IS VisualComponent THEN
- vc := c(VisualComponent); r := vc.bounds.Get();
- IF Rectangles.Intersect(r, cr) THEN (* only draw if the component has a chance to be visible *)
- canvas.SetClipRect(r); canvas.SetClipMode({WMGraphics.ClipRect});
- canvas.ClipRectAsNewLimits(r.l, r.t);
- vc.Draw(canvas);
- canvas.RestoreState(canvasState);
- END;
- END;
- c := GetNext(c);
- END;
- END DrawSubComponents;
- PROCEDURE GetFont*() : WMGraphics.Font;
- BEGIN
- IF font.Get() = NIL THEN RETURN WMGraphics.GetDefaultFont()
- ELSE RETURN font.Get()
- END
- END GetFont;
- PROCEDURE SetFont*(font : WMGraphics.Font);
- BEGIN
- Acquire;
- IF SELF.font.Get() # font THEN
- SELF.font.Set(font);
- (*?Invalidate()*) (* Invalidate already in PropertyChanged() *)
- END;
- Release
- END SetFont;
- PROCEDURE ScaleFont*(height: LONGINT; percent: LONGINT);
- VAR fh,newSize: LONGINT; f: WMGraphics.Font;
- BEGIN
- IF height < 4 THEN height := 4 END;
- IF percent <= 0 THEN RETURN END;
- Acquire;
- f := GetFont();
- f := WMGraphics.GetFont(f.name, 100, f.style); (* expensive ? *)
- fh := f.GetAscent() + f.GetDescent();
- fh := height * percent DIV fh;
- IF fh > 100 THEN fh := fh - fh MOD 8
- ELSIF fh > 32 THEN fh := fh - fh MOD 4
- ELSIF fh > 12 THEN fh := fh - fh MOD 2
- END;
- IF font.GetSize() # fh THEN
- font.SetSize(fh);
- Invalidate;
- END;
- Release;
- END ScaleFont;
- (** Called by the component owner whenever a redraw to a canvas is needed. Caller must hold hierarchy lock *)
- PROCEDURE Draw*(canvas : WMGraphics.Canvas);
- VAR command: Strings.String; event: Event;
- BEGIN
- (*
- can lead to deadlock:
- we hold the lock "lock"
- onDraw tries to get the Objects lock, but this may be held by other component (should better not, but did, dead: WMPartitionsComponents.OperationEventHandler
- command := GetAttributeValue("onDraw");
- IF (command # NIL) THEN HandleEvent(event, SELF, command); END;
- *)
- CheckReadLock;
- IF ~visible.Get() THEN RETURN END;
- canvas.SaveState(canvasState);
- IF font # NIL THEN canvas.SetFont(font.Get()) END;
- DrawBackground(canvas);
- IF extDraw # NIL THEN extDraw(canvas) END;
- DrawSelection(canvas);
- DrawSubComponents(canvas);
- DrawForeground(canvas);
- canvas.RestoreState(canvasState)
- END Draw;
- (** declare a rectangle area as dirty *)
- PROCEDURE InvalidateRect*(r: Rectangles.Rectangle);
- VAR parent : XML.Element;
- m : Messages.Message; b : Rectangles.Rectangle;
- BEGIN
- IF ~initialized THEN RETURN END;
- IF ~visible.Get() THEN RETURN END;
- IF ~IsCallFromSequencer() THEN
- m.msgType := Messages.MsgInvalidate;
- m.msgSubType := Messages.MsgSubRectangle;
- (*
- m.msgType := Messages.MsgExt;
- m.ext := invalidateRectMsg;
- *)
- m.x := r.l; m.y := r.t; m.dx := r.r; m.dy := r.b; m.sender := SELF;
- IF sequencer.Add(m) THEN IF CanYield THEN Objects.Yield END END;
- ELSE
- parent := GetParent();
- IF (parent # NIL) & (parent IS VisualComponent) THEN
- b := bounds.Get();
- Rectangles.MoveRel(r, b.l, b.t);
- parent(VisualComponent).InvalidateRect(r)
- END
- END
- END InvalidateRect;
-
- PROCEDURE PostInvalidateCommand*(sender, par : ANY);
- VAR m: Messages.Message; r, b: Rectangles.Rectangle; client: VisualComponent; parent: XML.Element;
- BEGIN
- IF ~initialized OR ~visible.Get() THEN RETURN END; (*? double call to visible.Get here and below. Which one is better ?*)
- r := GetClientRect();
- client := SELF;
- parent := GetParent();
- WHILE (parent # NIL) & (parent IS VisualComponent) DO
- IF ~parent(VisualComponent).visible.Get() THEN RETURN END;
- b := client.bounds.Get();
- Rectangles.MoveRel(r, b.l, b.t);
- client := parent(VisualComponent);
- parent := client.GetParent();
- END;
- m.msgType := Messages.MsgInvalidate;
- m.msgSubType := Messages.MsgSubRectangle;
- m.x := r.l; m.y := r.t; m.dx := r.r; m.dy := r.b;
- m.sender := client;
- IF sequencer.Add(m) THEN IF CanYield THEN Objects.Yield END END;
- END PostInvalidateCommand;
- PROCEDURE InvalidateCommand*(sender, par : ANY);
- VAR m: Messages.Message; r, b: Rectangles.Rectangle; client: VisualComponent; parent: XML.Element;
- BEGIN
- IF ~initialized OR ~visible.Get() THEN RETURN END; (*? double call to visible.Get here and below. Which one is better ?*)
- IF ~IsCallFromSequencer() OR ~visible.Get() THEN
- PostInvalidateCommand(sender, par);
- ELSE
- InvalidateRect(GetClientRect());
- END;
- END InvalidateCommand;
- PROCEDURE Invalidate*; (* For convenience in component internal use *)
- BEGIN
- PostInvalidateCommand(SELF, NIL)
- END Invalidate;
- (** recursively disable the redrawing of any components in the hierarchy *)
- (** dont forget to re-enable it ;-). Use with care to optimize sub-component operations *)
- PROCEDURE DisableUpdate*;
- VAR vc: VisualComponent;
- BEGIN
- ASSERT(IsCallFromSequencer());
- vc := GetVisualComponentRoot();
- IF (vc # NIL) & (vc IS Form) THEN vc(Form).DisableUpdate() END
- END DisableUpdate;
- (** recursively enable the redrawing of any components in the hierarchy *)
- (** Only enable drawing if it was disabled before, but dont forget it, then ! *)
- PROCEDURE EnableUpdate*;
- VAR vc: VisualComponent;
- BEGIN
- ASSERT(IsCallFromSequencer());
- vc := GetVisualComponentRoot();
- IF (vc # NIL) & (vc IS Form) THEN vc(Form).EnableUpdate() END
- END EnableUpdate;
- PROCEDURE GetInternalPointerInfo*() : WM.PointerInfo;
- VAR vc: VisualComponent;
- BEGIN
- ASSERT(IsCallFromSequencer());
- vc := GetVisualComponentRoot();
- IF (vc # NIL) & (vc IS Form) THEN
- RETURN vc(Form).GetPointerInfo()
- ELSE
- RETURN NIL
- END
- END GetInternalPointerInfo;
- PROCEDURE SetInternalPointerInfo*(pi : WM.PointerInfo);
- VAR vc: VisualComponent;
- BEGIN
- AssertLock;
- vc := GetVisualComponentRoot();
- IF (vc # NIL) & (vc IS Form) THEN vc(Form).SetPointerInfo(pi) END
- END SetInternalPointerInfo;
- PROCEDURE SetPointerInfo*(pi : WM.PointerInfo);
- BEGIN
- Acquire;
- SetInternalPointerInfo(pi);
- pointerInfo := pi;
- Release
- END SetPointerInfo;
- PROCEDURE GetPointerInfo*() : WM.PointerInfo;
- BEGIN
- RETURN pointerInfo
- END GetPointerInfo;
- (** User interaction messages *)
- PROCEDURE SetExtPointerLeaveHandler*(handler : PointerLeaveHandler);
- BEGIN
- Acquire; extPointerLeave := handler; Release
- END SetExtPointerLeaveHandler;
- PROCEDURE SetExtPointerDownHandler*(handler : PointerHandler);
- BEGIN
- Acquire; extPointerDown := handler; Release
- END SetExtPointerDownHandler;
- PROCEDURE SetExtPointerMoveHandler*(handler : PointerHandler);
- BEGIN
- Acquire; extPointerMove := handler; Release
- END SetExtPointerMoveHandler;
- PROCEDURE SetExtPointerUpHandler*(handler : PointerHandler);
- BEGIN
- Acquire; extPointerUp := handler; Release
- END SetExtPointerUpHandler;
- PROCEDURE SetExtDragOverHandler*(handler : DragDropHandler);
- BEGIN
- Acquire; extDragOver := handler; Release
- END SetExtDragOverHandler;
- PROCEDURE SetExtDragDroppedHandler*(handler : DragDropHandler);
- BEGIN
- Acquire; extDragDropped := handler; Release
- END SetExtDragDroppedHandler;
- PROCEDURE SetExtDragResultHandler*(handler : DragResultHandler);
- BEGIN
- Acquire; extDragResult := handler; Release
- END SetExtDragResultHandler;
- PROCEDURE SetExtKeyEventHandler*(handler : KeyEventHandler);
- BEGIN
- Acquire; extKeyEvent := handler; Release
- END SetExtKeyEventHandler;
- PROCEDURE SetExtDrawHandler*(handler : DrawHandler);
- BEGIN
- Acquire; extDraw := handler; Release
- END SetExtDrawHandler;
- PROCEDURE SetExtFocusHandler*(handler : FocusHandler);
- BEGIN
- Acquire; extFocus := handler; Release
- END SetExtFocusHandler;
- PROCEDURE SetExtContextMenuHandler*(handler : ContextMenuHandler);
- BEGIN
- Acquire; extContextMenu := handler; Release
- END SetExtContextMenuHandler;
- PROCEDURE SetExtGetPositionOwnerHandler*(handler : GetPositionOwnerHandler);
- BEGIN
- Acquire; extGetPositionOwner := handler; Release;
- END SetExtGetPositionOwnerHandler;
- (** Indicates the pointing device has left the component without a key pressed down.
- May only be called from the sequencer thread.
- Components interested in this message can override this method instead of searching for the message in HandleInternal. *)
- PROCEDURE PointerLeave*; (** PROTECTED *)
- BEGIN ASSERT(IsCallFromSequencer());
- END PointerLeave;
- (** Indicates one of the pointer keys went down. keys is the set of buttons currently pressed. x, y is the position in component
- coordinates.
- May only be called from the sequencer thread.
- Components interested in this message can override this method instead of searching for the message in HandleInternal. *)
- PROCEDURE PointerDown*(x, y: LONGINT; keys: SET); (** PROTECTED *)
- BEGIN ASSERT(IsCallFromSequencer());
- IF keys = {2} THEN ShowContextMenu(x, y)
- END;
- END PointerDown;
- (** Indicates the pointer was moved. keys is the set of buttons currently pressed. x, y is the position in component
- coordinates.
- May only be called from the sequencer thread.
- Components interested in this message can override this method instead of searching for the message in HandleInternal. *)
- PROCEDURE PointerMove*(x, y: LONGINT; keys: SET); (** PROTECTED *)
- BEGIN ASSERT(IsCallFromSequencer());
- END PointerMove;
- PROCEDURE WheelMove*(dz: LONGINT); (** PROTECTED *)
- BEGIN ASSERT(IsCallFromSequencer());
- END WheelMove;
- (** Indicates one of the pointer keys went up. keys is the set of buttons currently pressed. x, y is the position in component
- coordinates.
- May only be called from the sequencer thread.
- Components interested in this message can override this method instead of searching for the message in HandleInternal. *)
- PROCEDURE PointerUp*(x, y: LONGINT; keys: SET); (** PROTECTED *)
- BEGIN ASSERT(IsCallFromSequencer());
- END PointerUp;
- (** The component can determine wheter the key was pressed or released by examining the
- Inputs.Release flag in flags. ucs contains the unicode equivalent of the key. Special input editors
- send the generated unicode characters via KeyEvent.
- May only be called from the sequencer thread.
- Components interested in this message can override this method instead of searching for the message in HandleInternal. *)
- PROCEDURE KeyEvent*(ucs : LONGINT; flags: SET; VAR keySym: LONGINT); (** PROTECTED *)
- BEGIN ASSERT(IsCallFromSequencer());
- END KeyEvent;
- PROCEDURE EditKeyEvents(ucs : LONGINT; flags: SET; VAR keySym: LONGINT): BOOLEAN; (** FINAL *)
- VAR event : KeyPressedEvent; command : Strings.String; scale: LONGINT;
- clone: Repositories.Component; parent: XML.Content; parentEditMode: BOOLEAN;
- enum: XMLObjects.Enumerator; obj: ANY;
- BEGIN
- ASSERT(IsCallFromSequencer());
- event.ucs := ucs; event.flags := flags; event.keysym := keySym;
- parent := GetParent();
- IF (parent # NIL) & (parent IS VisualComponent) & parent(VisualComponent).editMode.Get() THEN
- parentEditMode := TRUE
- ELSE
- parentEditMode := FALSE
- END;
- IF ({Inputs.Release} * flags = {}) THEN
- IF (keySym = Inputs.KsF1) & (Inputs.Shift * flags # {}) THEN
- SetEditMode(~editMode.Get(), FALSE);
- RETURN TRUE
- ELSIF (keySym = Inputs.KsEscape) THEN
- selection.Reset(NIL);
- RETURN FALSE
- ELSIF parentEditMode OR editMode.Get() THEN
- IF Inputs.Shift * flags # {} THEN scale := 1 ELSE scale := 4 END;
- IF keySym = Inputs.KsLeft THEN selection.Shift(-scale,0); RETURN TRUE
- ELSIF keySym = Inputs.KsRight THEN selection.Shift(scale,0); RETURN TRUE
- ELSIF keySym = Inputs.KsDown THEN selection.Shift(0,scale); RETURN TRUE
- ELSIF keySym = Inputs.KsUp THEN selection.Shift(0,-scale); RETURN TRUE
- ELSIF keySym=4 (* CTRL-D *) THEN
- clone := Clone(selection.first.component);
- parent := selection.first.component.GetParent(); parent(Component).AddContent(clone);
- RETURN TRUE
- ELSIF keySym=1 THEN (* CTRL-A *)
- enum := GetContents();
- WHILE enum.HasMoreElements() DO
- obj := enum.GetNext();
- IF obj IS VisualComponent THEN
- selection.Add(obj(VisualComponent))
- END;
- END;
- ELSIF keySym = Inputs.KsDelete THEN
- RemoveSelection();
- RETURN TRUE
- END;
- END
- END;
- RETURN FALSE;
- END EditKeyEvents;
- PROCEDURE CheckKeyEvents(ucs : LONGINT; flags: SET; VAR keySym: LONGINT); (** FINAL *)
- VAR event : KeyPressedEvent; command : Strings.String; scale: LONGINT; clone: Repositories.Component; parent: XML.Content;
- BEGIN
- ASSERT(IsCallFromSequencer());
- event.ucs := ucs; event.flags := flags; event.keysym := keySym;
- IF ({Inputs.Release} * flags = {}) THEN
- IF (keySym = Inputs.KsReturn) THEN
- command := GetAttributeValue("onReturn");
- ELSIF (keySym = Inputs.KsEscape) THEN
- command := GetAttributeValue("onEscape");
- selection.Reset(NIL);
- (*ELSIF (keySym = Inputs.KsF1) & (Inputs.Shift * flags # {}) THEN
- SetEditMode(~editMode.Get(), TRUE);
- ELSIF editMode.Get() THEN
- IF Inputs.Shift * flags # {} THEN scale := 1 ELSE scale := 4 END;
- IF keySym = Inputs.KsLeft THEN selection.Shift(-scale,0)
- ELSIF keySym = Inputs.KsRight THEN selection.Shift(scale,0)
- ELSIF keySym = Inputs.KsDown THEN selection.Shift(0,scale)
- ELSIF keySym = Inputs.KsUp THEN selection.Shift(0,-scale)
- ELSIF keySym=4 (* CTRL-D *) THEN
- clone := Clone(selection.first.component);
- parent := selection.first.component.GetParent(); parent(Component).AddContent(clone);
- ELSIF keySym = Inputs.KsDelete THEN
- RemoveSelection();
- END;
- *)
- END;
- IF (command # NIL) THEN HandleEvent(event, SELF, command); END;
- command := GetAttributeValue("onKeyPressed");
- IF (command # NIL) THEN HandleEvent(event, SELF, command); END;
- ELSE
- command := GetAttributeValue("onKeyReleased");
- IF (command # NIL) THEN HandleEvent(event, SELF, command); END;
- END;
- END CheckKeyEvents;
- PROCEDURE CheckPointerEvent(x, y, z : LONGINT; keys : SET);
- VAR event : PointerEvent; command : Strings.String;
- BEGIN
- ASSERT(IsCallFromSequencer());
- event.x := x; event.y := y; event.z := z; event.keys := keys;
- IF ({0} * keys = {0}) THEN
- command := GetAttributeValue("onLeftClick");
- ELSIF ({2} * keys = {2}) THEN
- command := GetAttributeValue("onRightClick");
- ELSIF ({1} * keys = {1}) THEN
- command := GetAttributeValue("onMiddleClick");
- END;
- IF (command # NIL) THEN HandleEvent(event, SELF, command); END;
- command := GetAttributeValue("onClick");
- IF (command # NIL) THEN HandleEvent(event, SELF, command); END;
- END CheckPointerEvent;
- PROCEDURE CheckPointerUpEvent(x, y, z : LONGINT; keys : SET);
- VAR event : PointerEvent; command : Strings.String;
- BEGIN
- ASSERT(IsCallFromSequencer());
- event.x := x; event.y := y; event.z := z; event.keys := keys;
- command := GetAttributeValue("onRelease");
- IF (command # NIL) THEN HandleEvent(event, SELF, command); END;
- END CheckPointerUpEvent;
- PROCEDURE InEditBounds(x,y: LONGINT): LONGINT;
- CONST Border = 8;
- VAR left, right, top, bottom: LONGINT;
- BEGIN
- left := bounds.GetLeft();
- right := bounds.GetRight();
- top := bounds.GetTop();
- bottom := bounds.GetBottom();
- INC(x,left); INC(y,top); (* relative -> absolute *)
- IF (ABS(left-x) <= Border) THEN
- IF (ABS(top-y) <= Border) THEN
- RETURN UpperLeft
- ELSIF (ABS(bottom-y) <= Border) THEN
- RETURN LowerLeft
- ELSE
- RETURN Left
- END
- ELSIF (ABS(right-x) <= Border) THEN
- IF (ABS(top-y) <= Border) THEN
- RETURN UpperRight
- ELSIF (ABS(bottom-y) <= Border) THEN
- RETURN LowerRight
- ELSE
- RETURN Right
- END
- ELSIF (ABS(y-top) <= Border) THEN
- RETURN Upper
- ELSIF (ABS(bottom-y) <= Border) THEN
- RETURN Lower
- ELSIF (x > left+Border) & (x < right-Border) & (y > top+Border) & (y< bottom-Border) THEN
- RETURN Inside
- ELSE
- RETURN None
- END;
- END InEditBounds;
- PROCEDURE Edit(VAR msg: Messages.Message);
- VAR region: LONGINT; dx,dy: LONGINT; b: Rectangles.Rectangle; manager: WM.WindowManager;
- w,h: LONGINT; img: WMGraphics.Image; canvas: WMGraphics.BufferCanvas; e: ComponentListEntry;
- alignRelative : BOOLEAN;
- BEGIN
- IF msg.msgSubType = Messages.MsgSubPointerUp THEN
- editRegion := None;
- SetPointerInfo(oldPointerInfo);
- RETURN
- END;
- dx := msg.x-editX; dy := msg.y-editY;
- b := bounds.Get();
- IF editRegion = Right THEN
- b.r := b.r + dx
- ELSIF editRegion = Left THEN
- b.l := b.l + dx; dx := 0;
- ELSIF editRegion = Lower THEN
- b.b := b.b + dy
- ELSIF editRegion = Upper THEN
- b.t := b.t + dy; dy := 0;
- ELSIF editRegion = LowerLeft THEN
- b.b := b.b + dy;
- b.l := b.l + dx; dx := 0;
- ELSIF editRegion = LowerRight THEN
- b.b := b.b + dy;
- b.r := b.r + dx
- ELSIF editRegion = UpperLeft THEN
- b.t := b.t + dy; dy := 0;
- b.l := b.l + dx; dx := 0;
- ELSIF editRegion = UpperRight THEN
- b.t := b.t + dy; dy := 0;
- b.r := b.r + dx
- ELSIF (editRegion = Inside) & ((dx # 0) OR (dy # 0)) THEN
- img := selection.ToImg(SELF,e);
- IF e # NIL THEN
- IF StartDrag(selection,img,-msg.x-e.dx,-msg.y-e.dy, EditMoved,NIL) THEN END;
- END;
- RETURN
- END;
- AdaptRelativeBounds(b, GetParent());
- bounds.Set(b);
- editX := editX + dx; editY := editY + dy;
- END Edit;
- PROCEDURE SetEditMode*(mode: BOOLEAN; recurse: BOOLEAN);
- VAR vc: VisualComponent; c: XML.Content;
- BEGIN
- Acquire;
- editMode.Set(mode);
- IF recurse THEN
- c := GetFirst();
- WHILE (c # NIL) DO
- IF c IS VisualComponent THEN
- vc := c(VisualComponent);
- vc.SetEditMode(mode, TRUE);
- END;
- c := GetNext(c);
- END;
- END;
- Release;
- END SetEditMode;
- PROCEDURE EditMoved(sender, data: ANY);
- VAR parent: XML.Element; ldata: ANY; e: ComponentListEntry;
- BEGIN
- IF (sender # SELF) THEN
- IF (data # NIL) & (data IS WM.DragInfo) THEN
- ldata := data(WM.DragInfo).data;
- IF (ldata # NIL) & (ldata IS XML.Element) THEN
- parent := ldata(XML.Element).GetParent();
- parent.RemoveContent(ldata(XML.Element));
- parent(VisualComponent).Invalidate;
- ELSIF (ldata # NIL) & (ldata IS SelectionList) THEN
- e := ldata(SelectionList).first;
- WHILE e # NIL DO
- parent := e.component.GetParent();
- ldata := e.component;
- parent.RemoveContent(ldata(XML.Element));
- parent(VisualComponent).Invalidate;
- e := e.next;
- END;
- END;
- END;
- END;
- END EditMoved;
- PROCEDURE HandleInternal*(VAR msg : Messages.Message); (** PROTECTED *)
- VAR
- po : VisualComponent; nm : Messages.Message; handled : BOOLEAN; b : Rectangles.Rectangle;
- r, v : VisualComponent;
- p : XML.Element;
- keyFlags: SET; manager : WM.WindowManager;
- currentEditRegion: LONGINT;
- parent: XML.Element;
- parentEditMode: BOOLEAN;
- BEGIN
- ASSERT(IsCallFromSequencer());
- handled := FALSE;
- IF msg.msgType = Messages.MsgPointer THEN
- parent := GetParent();
- IF (parent # NIL) & (parent IS VisualComponent) & parent(VisualComponent).editMode.Get() THEN
- parentEditMode := TRUE
- ELSE
- parentEditMode := FALSE
- END;
- IF msg.msgSubType = Messages.MsgSubPointerMove THEN
- IF (msg.flags * {0, 1, 2} = {}) OR (fPointerOwner = NIL) THEN
- IF parentEditMode & ~editMode.Get() THEN fPointerOwner := SELF; handled := TRUE
- ELSIF ~parentEditMode & (extGetPositionOwner # NIL) THEN extGetPositionOwner(msg.x, msg.y, fPointerOwner, handled);
- END;
- IF ~handled THEN
- po := GetPositionOwner(msg.x, msg.y);
- IF po # fPointerOwner THEN
- nm.msgType := Messages.MsgPointer;
- nm.msgSubType := Messages.MsgSubPointerLeave;
- HandleInternal(nm)
- END;
- fPointerOwner := po
- ELSE
- handled := FALSE;
- END;
- END
- END;
- IF (fPointerOwner = SELF) THEN
- IF (msg.originator # NIL) & (msg.originator IS WM.ViewPort) THEN
- manager := msg.originator(WM.ViewPort).manager;
- msg.originator(WM.ViewPort).GetKeyState(keyFlags);
- END;
- IF parentEditMode & (editRegion # None) THEN
- Edit(msg)
- ELSE
- IF msg.msgSubType = Messages.MsgSubPointerMove THEN
- IF (parentEditMode) & (msg.originator # NIL) & (msg.originator IS WM.ViewPort) THEN
- currentEditRegion := InEditBounds(msg.x, msg.y);
- CASE currentEditRegion OF
- | Lower, Upper: SetPointerInfo(manager.pointerUpDown)
- | Left, Right:SetPointerInfo(manager.pointerLeftRight)
- | LowerLeft, UpperRight:SetPointerInfo(manager.pointerURDL)
- | UpperLeft, LowerRight: SetPointerInfo(manager.pointerULDR)
- | Inside: SetPointerInfo(manager.pointerMove)
- ELSE
- IF oldPointerInfo # NIL THEN
- SetPointerInfo(oldPointerInfo); oldPointerInfo := NIL;
- ELSE oldPointerInfo := GetPointerInfo();
- END;
- END;
- END;
- IF extPointerMove # NIL THEN extPointerMove(msg.x, msg.y, msg.flags, handled) END;
- SetInternalPointerInfo(pointerInfo);
- IF ~handled THEN PointerMove(msg.x, msg.y, msg.flags) END;
- IF msg.dz # 0 THEN WheelMove(msg.dz) END
- ELSIF msg.msgSubType = Messages.MsgSubPointerDown THEN
- IF parentEditMode THEN
- editRegion := InEditBounds(msg.x, msg.y);
- END;
- (*
- IF (msg.originator # NIL) & (msg.originator IS WM.ViewPort) THEN
- msg.originator(WM.ViewPort).GetKeyState(keyFlags);
- IF (keyFlags # {}) & (keyFlags <= Inputs.Ctrl) THEN editRegion := InEditBounds(msg.x, msg.y) ELSE editRegion := None END;
- ELSE
- editRegion := None
- END;
- *)
- IF editRegion # None THEN
- IF (keyFlags # {}) & (keyFlags <= Inputs.Shift) THEN
- selection.Toggle(SELF)
- ELSIF ~selection.Has(SELF) THEN selection.Reset(SELF)
- END;
- manager := msg.originator(WM.ViewPort).manager;
- editX := msg.x; editY := msg.y;
- ELSE
- IF extPointerDown # NIL THEN extPointerDown(msg.x, msg.y, msg.flags, handled) END;
- IF ~handled THEN PointerDown(msg.x, msg.y, msg.flags) END;
- END;
- SetFocus
- ELSIF msg.msgSubType = Messages.MsgSubPointerUp THEN
- IF extPointerUp # NIL THEN extPointerUp(msg.x, msg.y, msg.flags, handled) END;
- IF ~handled THEN PointerUp(msg.x, msg.y, msg.flags) END
- ELSIF msg.msgSubType = Messages.MsgSubPointerLeave THEN
- IF extPointerLeave # NIL THEN extPointerLeave(handled) END;
- IF ~handled THEN PointerLeave END
- END;
- IF ~parentEditMode & (msg.flags * {0, 1, 2} # {}) THEN
- IF (msg.msgSubType = Messages.MsgSubPointerDown) THEN
- CheckPointerEvent(msg.x, msg.y, msg.z, msg.flags);
- ELSIF msg.msgSubType = Messages.MsgSubPointerUp THEN
- CheckPointerUpEvent(msg.x, msg.y, msg.z, msg.flags);
- END;
- END;
- END;
- ELSE
- b := fPointerOwner.bounds.Get();
- msg.x := msg.x - b.l; msg.y := msg.y - b.t;
- fPointerOwner.Handle(msg)
- END
- ELSIF msg.msgType = Messages.MsgKey THEN
- IF focusComponent # SELF THEN focusComponent.Handle(msg)
- ELSIF EditKeyEvents(msg.x, msg.flags, msg.y) THEN
- handled := TRUE;
- ELSIF (visible.Get()) THEN
- IF ~needsTab.Get() & (msg.y = 0FF09H) THEN
- IF (Inputs.Shift * msg.flags # {}) THEN FocusPrev ELSE FocusNext END
- ELSIF msg.y = 0FF67H THEN ShowContextMenu(0, 0)
- ELSE
- IF extKeyEvent # NIL THEN extKeyEvent(msg.x, msg.flags, msg.y, handled) END;
- IF ~handled THEN KeyEvent(msg.x, msg.flags, msg.y) END;
- CheckKeyEvents(msg.x, msg.flags, msg.y);
- END
- END;
- ELSIF msg.msgType = Messages.MsgDrag THEN
- IF extGetPositionOwner # NIL THEN extGetPositionOwner(msg.x, msg.y, po, handled); END;
- IF ~handled THEN
- po := GetPositionOwner(msg.x, msg.y);
- ELSE
- handled := FALSE;
- END;
- IF (po # SELF) & editMode.Get() & (~po.editMode.Get() OR (msg.ext # NIL) & (msg.ext(WM.DragInfo).data=po)) THEN
- po := SELF
- ELSIF (msg.ext # NIL) & (msg.ext(WM.DragInfo).data # NIL) & (msg.ext(WM.DragInfo).data IS ToggleEditMode) & (msg.ext(WM.DragInfo).data(ToggleEditMode).recursion = Recursion.FromBottom) THEN
- po := SELF
- END;
- IF (po # SELF) THEN (* Let child handle the drag and drop message *)
- b := po.bounds.Get();
- msg.x := msg.x - b.l; msg.y := msg.y - b.t;
- po.Handle(msg)
- ELSE (* handle the drag and drop message *)
- IF msg.msgSubType = Messages.MsgDragOver THEN
- IF (msg.ext # NIL) THEN
- IF extDragOver # NIL THEN extDragOver(msg.x, msg.y, msg.ext(WM.DragInfo), handled) END;
- IF ~handled THEN po.DragOver(msg.x, msg.y, msg.ext(WM.DragInfo)) END
- END
- ELSIF msg.msgSubType = Messages.MsgDragDropped THEN
- IF (msg.ext # NIL) THEN
- IF (msg.ext(WM.DragInfo).data # NIL) & (msg.ext(WM.DragInfo).data IS ToggleEditMode) THEN
- SetEditMode(~editMode.Get(), msg.ext(WM.DragInfo).data(ToggleEditMode).recursion # Recursion.None);
- Invalidate;
- ELSIF editMode.Get() THEN
- handled := EditDragDropped(msg.x,msg.y,msg.ext(WM.DragInfo));
- ELSIF extDragDropped # NIL THEN
- extDragDropped(msg.x, msg.y, msg.ext(WM.DragInfo), handled)
- END;
- IF ~handled THEN
- po.DragDropped(msg.x, msg.y, msg.ext(WM.DragInfo))
- END
- END
- END
- END
- ELSIF (msg.msgType = Messages.MsgFocus) & (msg.msgSubType = Messages.MsgSubFocusLost) THEN
- (* unset the old focus chain *)
- r := GetVisualComponentRoot(); (* find the leaf component that has the focus *)
- WHILE (r # NIL) & (r.focusComponent # NIL) & (r.focusComponent # r) DO r := r.focusComponent END;
- p := r; (* clear the focus chain until the root or this component *)
- WHILE (p # SELF) & (p # NIL) & (p IS VisualComponent) DO
- v := p(VisualComponent);
- v.focusComponent := v;
- v.FocusLost; IF v.extFocus # NIL THEN v.extFocus(FALSE) END; p := p.GetParent()
- END;
- ELSIF msg.msgType = Messages.MsgInvalidate THEN
- IF msg.msgSubType = Messages.MsgSubAll THEN
- msg.sender(VisualComponent).InvalidateRect(GetClientRect());
- ELSIF msg.msgSubType = Messages.MsgSubRectangle THEN
- msg.sender(VisualComponent).InvalidateRect(Rectangles.MakeRect(msg.x, msg.y, msg.dx, msg.dy));
- ELSE (* nothing to do *)
- END;
- ELSIF msg.msgType = Messages.MsgExt THEN
- IF msg.ext = invalidateRectMsg THEN
- TRACE("WARNING: OLD MESSAGE FORM");
- msg.sender(VisualComponent).InvalidateRect(Rectangles.MakeRect(msg.x, msg.y, msg.dx, msg.dy))
- ELSE
- BroadcastSubcomponents(msg);
- END
- ELSE HandleInternal^(msg)
- END;
- END HandleInternal;
- END VisualComponent;
- GetPositionOwnerHandler* = PROCEDURE {DELEGATE} (x, y : LONGINT; VAR positionOwner : VisualComponent; VAR handled : BOOLEAN);
- TYPE
- (* Layout Manager *)
- LayoutManager* = PROCEDURE {DELEGATE} (vc : VisualComponent);
- FormWindow* = OBJECT(WM.DoubleBufferWindow)
- VAR
- form- : Form;
- cs : WMGraphics.CanvasState;
- disableUpdate : LONGINT;
- content : VisualComponent;
- scaling* : BOOLEAN;
- PROCEDURE ToXML*():XML.Content;
- VAR winx: XML.Element; a: XML.Attribute; string: ARRAY 128 OF CHAR; title:Strings.String;
- BEGIN {EXCLUSIVE}
- NEW(winx); winx.SetName("FormWindow");
- NEW(a); a.SetName("name");
- title:=GetTitle(); IF title=NIL THEN a.SetValue("componentWindow") ELSE a.SetValue(title^) END;
- winx.AddAttribute(a);
- NEW(a); a.SetName("loader"); a.SetValue("WMComponents.FormWindowGen"); winx.AddAttribute(a);
- NEW(a); a.SetName("l"); Strings.IntToStr(bounds.l, string); a.SetValue(string); winx.AddAttribute(a);
- NEW(a); a.SetName("t"); Strings.IntToStr(bounds.t, string); a.SetValue(string); winx.AddAttribute(a);
- NEW(a); a.SetName("r"); Strings.IntToStr(bounds.r, string); a.SetValue(string); winx.AddAttribute(a);
- NEW(a); a.SetName("b"); Strings.IntToStr(bounds.b, string); a.SetValue(string); winx.AddAttribute(a);
- NEW(a); a.SetName("flags"); Strings.SetToStr(flags, string); a.SetValue(string); winx.AddAttribute(a);
- NEW(a); a.SetName("canvasGenerator"); a.SetValue(canvas.generator^); winx.AddAttribute(a);
- winx.AddContent(form);
- RETURN winx
- END ToXML;
-
- PROCEDURE LoadComponents*(xml: XML.Element);
- VAR component: Repositories.Component;
- BEGIN
- IF xml # NIL THEN
- component := Repositories.ComponentFromXML(xml);
- IF (component # NIL) & (component IS VisualComponent) THEN
- SetContent(component);
- ELSE
- KernelLog.String("formwindow could not load content"); KernelLog.Ln;
- END;
- END;
- END LoadComponents;
- PROCEDURE StoreComponents*(): XML.Element;
- BEGIN RETURN content (* do not store form separately *)
- END StoreComponents;
- PROCEDURE SetContent*(x : XML.Content);
- VAR c: XML.Content;
- m:Messages.Message;
- BEGIN
- IF sequencer # NIL THEN sequencer.WaitFree() END;
- BEGIN{EXCLUSIVE}
- INC(disableUpdate);
- INCL(flags, 13); (* render windows background non-displayed*)
- IF form # NIL THEN form.Finalize; form.sequencer.Stop; content:=NIL END;
- IF x IS Form THEN
- form := x(Form);
- form.initialized:=FALSE;
- form.SetWindow(SELF); (* includes new sequencer *)
- c:=form.GetFirst(); (* get first VisualComponent content of form*)
- WHILE (c#NIL) & (c IS XML.Container) & ~(c IS VisualComponent) DO
- c:=c(XML.Container).GetNext(c);
- END;
- IF c#NIL THEN form.RemoveContent(c) END; (* avoid duplicates. will be added in a systematic way below in AddContent *)
- ELSE
- NEW(form, SELF); (* includes new sequencer; initialized=FALSE *)
- form.uid.Set(NewString("form"));
- c:=x;
- END;
- IF (c#NIL) & (c IS VisualComponent) THEN
- content := c(VisualComponent);
- form.initialized:=TRUE;
- form.AddContent(content);
- form.focusComponent := content;
- form.fPointerOwner := content;
- END;
- DEC(disableUpdate);
- END;
- (*form.Initialize;*)(*implied above*)
- (*form.Invalidate;*)(*implied above*)
- END SetContent;
- PROCEDURE DisableUpdate*;
- BEGIN {EXCLUSIVE}
- INC(disableUpdate);
- ASSERT(disableUpdate # -1); (* overflow *)
- END DisableUpdate;
- PROCEDURE EnableUpdate*;
- BEGIN {EXCLUSIVE}
- DEC(disableUpdate);
- ASSERT(disableUpdate # -1); (* underflow *)
- END EnableUpdate;
- PROCEDURE Resized( width, height: LONGINT);
- BEGIN
- IF ~scaling THEN
- DisableUpdate;
- form.Acquire;
- ReInit(width, height);
- form.Release;
- form.bounds.Set(Rectangles.MakeRect(0, 0, GetWidth(), GetHeight()));
- content.bounds.Set(Rectangles.MakeRect(0, 0, GetWidth(), GetHeight()));
- EnableUpdate;
- form.Invalidate()
- END
- END Resized;
- PROCEDURE Trap():BOOLEAN;
- BEGIN
- KernelLog.String("WMComponents.FormWindow.Trap !!! --> Resetting Locks "); KernelLog.Ln;
- form.sequencer.lock.Reset;
- RETURN TRUE
- END Trap;
- PROCEDURE Update(rect : Rectangles.Rectangle);
- BEGIN
- (*KernelLog.String("Update "); KernelLog.Int(disableUpdate,0); KernelLog.Ln;*)
- IF disableUpdate > 0 THEN RETURN END;
- form.Acquire;
- canvas.SaveState(cs);
- canvas.SetClipRect(rect);
- canvas.ClipRectAsNewLimits(0, 0);
- IF Raster.alpha IN img.fmt.components THEN
- canvas.Fill(rect, 0H, WMGraphics.ModeCopy)
- ELSE
- canvas.Fill(rect, 0H (*0FFH*), Raster.clear(*WMGraphics.ModeCopy*))
- END;
- form.Draw(canvas);
- canvas.RestoreState(cs);
- form.Release;
- CopyRect(rect);
- Invalidate(rect)
- END Update;
-
- PROCEDURE Handle*(VAR m : Messages.Message);
- VAR pendingM: Messages.Message;
- BEGIN
- Handle^(m);
-
- IF (m.msgType = Messages.MsgExt) & (m.ext # NIL) THEN
- IF (m.ext = componentStyleMsg) THEN CSChanged
- END;
- ELSIF (m.msgType = Messages.MsgFocus) & (m.msgSubType = Messages.MsgSubFocusGot) THEN
- IF (form # NIL) & (form.lastFocusComponent # NIL) THEN
- form.lastFocusComponent.SetFocus;
- END;
- ELSIF (m.msgType = Messages.MsgSetLanguage) & (m.ext # NIL) & (m.ext IS LanguageExtension) THEN
- LanguageChanged(m.ext(LanguageExtension).languages);
- ELSIF (m.msgType=Messages.MsgInvalidate) THEN (* sent by WindowManager when a window is added to display space to assure it is up-to-date*)
- IF form=NIL THEN RETURN
- ELSE m.sender:=form; (* will be passed to form below, which will call sender.InvalidateRect *)
- END;
- END;
- IF (TraceFocus IN Trace) THEN
- IF (m.msgType = Messages.MsgFocus) THEN
- IF (m.msgSubType = Messages.MsgSubFocusGot) THEN
- KernelLog.String("Got Focus: "); form.TraceFocusChain;
- ELSIF (m.msgSubType = Messages.MsgSubMasterFocusGot) THEN
- KernelLog.String("Got Master Focus: "); form.TraceFocusChain;
- END;
- ELSIF (m.msgType = Messages.MsgKey) & (m.x = ORD("f")) THEN
- KernelLog.String("Focus chain: "); form.TraceFocusChain;
- END;
- END;
-
- IF (form # NIL) THEN form.Handle(m); END;
- END Handle;
- PROCEDURE LanguageChanged*(languages : Localization.Languages);
- BEGIN
- ASSERT(languages # NIL);
- END LanguageChanged;
- PROCEDURE CSChanged*;
- BEGIN
- DisableUpdate; (* the components are going to redraw like crazy *)
- form.Acquire;
- form.Reset(SELF, NIL);
- form.Release;
- EnableUpdate;
- END CSChanged;
- PROCEDURE Close*;
- BEGIN
- Close^; (* remove the form to avoid further messages *)
- IF form # NIL THEN
- form.Acquire;
- form.Finalize; form.sequencer.Stop;
- form.Release
- END;
- END Close;
- END FormWindow;
- Form* = OBJECT(VisualComponent)
- VAR
- window- : FormWindow;
- lastFocusComponent : VisualComponent;
- PROCEDURE &New*(window : FormWindow);
- BEGIN
- Init;
- SetGenerator("WMComponents.NewForm");
- lastFocusComponent := NIL;
- SetNameAsString(StrForm);
- SetWindow(window);
- END New;
-
- PROCEDURE SetWindow*(window: FormWindow);
- VAR seq: Messages.MsgSequencer;
- BEGIN {EXCLUSIVE}
- IF window # NIL THEN
- SELF.window := window;
- window.form := SELF;
- bounds.Set(Rectangles.MakeRect(0, 0, window.GetWidth(), window.GetHeight()));
- NEW(seq, Handle); seq.SetTrapHandler(window.Trap); SetSequencer(seq);
- END;
- END SetWindow;
- PROCEDURE GetPointerInfo*() : WM.PointerInfo;
- BEGIN
- ASSERT(IsCallFromSequencer());
- IF window # NIL THEN RETURN window.pointerInfo ELSE RETURN NIL END
- END GetPointerInfo;
- PROCEDURE SetPointerInfo*(pi : WM.PointerInfo);
- BEGIN
- ASSERT(IsCallFromSequencer());
- IF window # NIL THEN window.SetPointerInfo(pi) END;
- END SetPointerInfo;
- PROCEDURE DisableUpdate*;
- BEGIN
- ASSERT(IsCallFromSequencer());
- IF window # NIL THEN window.DisableUpdate END
- END DisableUpdate;
- PROCEDURE EnableUpdate*;
- BEGIN
- ASSERT(IsCallFromSequencer());
- IF window # NIL THEN window.EnableUpdate END
- END EnableUpdate;
- PROCEDURE InvalidateRect*(rect : Rectangles.Rectangle);
- BEGIN
- IF window # NIL THEN
- BEGIN{EXCLUSIVE} AWAIT(initialized) END;
- window.Update(rect)
- END;
- END InvalidateRect;
- PROCEDURE PropertyChanged*(sender, property : ANY);
- VAR w,h: LONGINT;
- BEGIN
- IF property = bounds THEN
- IF ~ Rectangles.IsEqual(window.bounds, bounds.Get()) THEN
- bounds.GetExtents(w,h);
- IF window # NIL THEN
- window.manager.SetWindowSize(window,w,h);
- END;
- ELSE
- (*ScaleFont(bounds.GetHeight(), scaleFont.Get());*)
- Resized
- END;
- END
- END PropertyChanged;
- END Form;
- TYPE
- (** PropertyLists for style support *)
- PropertyListEntry = POINTER TO RECORD
- next : PropertyListEntry;
- name : Strings.String;
- list : WMProperties.PropertyList;
- END;
- ListArray* = POINTER TO ARRAY OF WMProperties.PropertyList;
- PropertyListList* = OBJECT
- VAR
- first : PropertyListEntry;
- PROCEDURE Find*(CONST name : ARRAY OF CHAR) : WMProperties.PropertyList;
- VAR cur : PropertyListEntry;
- BEGIN {EXCLUSIVE}
- cur := first;
- WHILE (cur # NIL) & (cur.name^ # name) DO cur := cur.next END;
- IF cur # NIL THEN RETURN cur.list
- ELSE RETURN NIL
- END
- END Find;
- PROCEDURE RemoveInternal(CONST name : ARRAY OF CHAR);
- VAR cur : PropertyListEntry;
- BEGIN
- IF first = NIL THEN RETURN END;
- IF (first # NIL) & (first.name^ = name) THEN first := first.next
- ELSE
- cur := first;
- WHILE (cur.next # NIL) DO
- IF (cur.next.name^ = name) THEN cur.next := cur.next.next END;
- cur := cur.next
- END
- END
- END RemoveInternal;
- PROCEDURE Remove*(CONST name : ARRAY OF CHAR);
- BEGIN {EXCLUSIVE}
- RemoveInternal(name)
- END Remove;
- PROCEDURE Add*(CONST name : ARRAY OF CHAR; pl : WMProperties.PropertyList);
- VAR new : PropertyListEntry;
- BEGIN {EXCLUSIVE}
- RemoveInternal(name);
- NEW(new); new.name := NewString(name); new.list := pl; new.next := first; first := new
- END Add;
- PROCEDURE Enumerate*() : ListArray;
- VAR array : ListArray; current : PropertyListEntry; i : LONGINT;
- BEGIN {EXCLUSIVE}
- i := 0;
- current := first;
- WHILE current # NIL DO INC(i); current := current.next END;
- NEW(array, i );
- current := first;
- i := 0;
- WHILE current # NIL DO
- array[i] := current.list;
- INC(i);
- current := current.next
- END;
- RETURN array
- END Enumerate;
- PROCEDURE UpdateStyle*;
- VAR
- en : XMLObjects.Enumerator;
- p : ANY; s : Strings.String;
- pl : WMProperties.PropertyList;
- BEGIN
- IF currentStyle = NIL THEN RETURN END;
- en := currentStyle.GetContents();
- WHILE en.HasMoreElements() DO
- p := en.GetNext();
- IF p IS XML.Element THEN
- s := p(XML.Element).GetName();
- pl := propertyListList.Find(s^);
- IF pl # NIL THEN pl.SetXML(p(XML.Element)) END
- END
- END
- END UpdateStyle;
- END PropertyListList;
- ComponentListEntry= POINTER TO RECORD
- component: VisualComponent;
- dx,dy: LONGINT;
- next: ComponentListEntry
- END;
- SelectionArray* = POINTER TO ARRAY OF VisualComponent;
- SelectionList*= OBJECT
- VAR first, last: ComponentListEntry; number: LONGINT; state: LONGINT; timer: Kernel.Timer;
- onChanged-: WMEvents.EventSource;
- lock: Locks.RecursiveLock;
- PROCEDURE &Init;
- BEGIN
- NEW(lock);
- first := NIL; last := NIL; number := 0; state := 0; NEW(onChanged, NIL, NIL, NIL, NIL);
- END Init;
- PROCEDURE Reset(this: VisualComponent);
- VAR entry: ComponentListEntry;
- BEGIN
- lock.Acquire;
- entry := first;
- first := NIL; last := NIL; number := 0;
- WHILE entry # NIL DO entry.component.Invalidate; entry := entry.next END;
- lock.Release;
- Add(this);
- onChanged.Call(SELF);
- END Reset;
- PROCEDURE Has*(this: ANY): BOOLEAN;
- VAR entry: ComponentListEntry;
- BEGIN
- IF first = NIL THEN RETURN FALSE END; (* no lock for usual case *)
- lock.Acquire;
- entry := first;
- WHILE (entry # NIL) & (entry.component # this) DO entry := entry.next END;
- lock.Release;
- RETURN entry # NIL
- END Has;
- PROCEDURE Add*(this: VisualComponent);
- VAR entry: ComponentListEntry;
- BEGIN
- IF (this = NIL) OR Has(this) THEN RETURN END;
- lock.Acquire;
- NEW(entry); entry.component := this; entry.next := NIL;
- IF last = NIL THEN
- ASSERT(first = NIL);
- first := entry; last := entry;
- ELSE
- last.next := entry; last := entry
- END;
- INC(number);
- lock.Release;
- this.Invalidate;
- onChanged.Call(SELF);
- END Add;
- PROCEDURE Remove*(this: VisualComponent);
- VAR entry, prev: ComponentListEntry;
- BEGIN
- lock.Acquire;
- entry := first; prev := NIL;
- WHILE (entry # NIL) & (entry.component # this) DO
- prev := entry;
- entry := entry.next;
- END;
- IF entry = NIL THEN lock.Release; RETURN END;
- IF prev # NIL THEN prev.next := entry.next END;
- IF entry = first THEN first := first.next END;
- IF entry = last THEN last := prev END;
- DEC(number);
- lock.Release;
- this.Invalidate;
- onChanged.Call(SELF);
- END Remove;
- PROCEDURE GetSelection*(): SelectionArray;
- VAR array: SelectionArray; i: LONGINT; e: ComponentListEntry;
- BEGIN
- lock.Acquire;
- NEW(array, number);
- e := first; i := 0;
- WHILE e # NIL DO
- array[i] := e.component;
- INC(i);
- e := e.next;
- END;
- lock.Release;
- RETURN array;
- END GetSelection;
- PROCEDURE Toggle*(this: VisualComponent);
- BEGIN
- IF Has(this) THEN Remove(this) ELSE Add(this) END;
- END Toggle;
- PROCEDURE Update;
- VAR e: ComponentListEntry;
- BEGIN
- e := first;
- WHILE e # NIL DO
- e.component.Invalidate;
- e := e.next;
- END;
- END Update;
- PROCEDURE Shift(dx, dy: LONGINT);
- VAR e: ComponentListEntry; rect: Rectangles.Rectangle;
- BEGIN
- e := first;
- WHILE e # NIL DO
- rect := e.component.bounds.Get();
- INC(rect.l,dx); INC(rect.r,dx);
- INC(rect.t,dy); INC(rect.b,dy);
- e.component.AdaptRelativeBounds(rect,e.component.GetParent());
- e.component.bounds.Set(rect);
- e := e.next
- END;
- END Shift;
- PROCEDURE ToImg(start: VisualComponent; VAR this: ComponentListEntry): WMGraphics.Image;
- VAR l,t,r,b: LONGINT; e: ComponentListEntry; rect: Rectangles.Rectangle; img, image: WMGraphics.Image; w,h: LONGINT;
- canvas: WMGraphics.BufferCanvas; srcCopy: Raster.Mode;
- BEGIN
- l := MAX(LONGINT); r := MIN(LONGINT);
- t := MAX(LONGINT); b := MIN(LONGINT);
- e := first;
- WHILE e # NIL DO
- rect := e.component(VisualComponent).bounds.Get();
- IF rect.l < l THEN l := rect.l END;
- IF rect.r > r THEN r := rect.r END;
- IF rect.t < t THEN t := rect.t END;
- IF rect.b > b THEN b := rect.b END;
- e := e.next;
- END;
- Raster.InitMode(srcCopy, Raster.srcCopy);
- NEW(image);
- w := r-l+1; h := b-t+1;
- Raster.Create(image, w,h, Raster.BGRA8888);
- e := first;
- WHILE e # NIL DO
- rect := e.component.bounds.Get();
- NEW(img);
- Raster.Create(img,rect.r-rect.l+1, rect.b-rect.t+1, Raster.BGRA8888);
- NEW(canvas,img);
- e.component.Draw(canvas);
- Raster.Copy(img,image,0,0,img.width-1, img.height-1,rect.l-l, rect.t-t, srcCopy);
- e.dx := rect.l-l; e.dy := rect.t-t;
- IF e.component = start THEN this := e END;
- e := e.next
- END;
- RETURN image
- END ToImg;
- BEGIN {ACTIVE}
- NEW(timer);
- LOOP
- timer.Sleep(400);
- state := (state + 1) MOD 2;
- Update;
- END
- END SelectionList;
- WindowGenerator*= PROCEDURE(xml: XML.Content): WM.Window;
- VAR
- hasErrors : BOOLEAN; (* accessed only from (EXCLUSIVE) *)
- invalidateRectMsg- : Messages.MessageExtension; (* used as unique ID *)
- PrototypeID, PrototypeUID : WMProperties.StringProperty;
- PrototypeBounds-, PrototypeBoundsRelative-, PrototypeBearing : WMProperties.RectangleProperty;
- PrototypeEnabled : WMProperties.BooleanProperty;
- PrototypeFillColor : WMProperties.ColorProperty;
- PrototypeAlignment : WMProperties.Int32Property;
- PrototypeVisible, PrototypeTakesFocus, PrototypeNeedsTab, PrototypeEditMode: WMProperties.BooleanProperty;
- PrototypeScaleFont: WMProperties.Int32Property;
- PrototypeFocusPrevious, PrototypeFocusNext : WMProperties.StringProperty;
- PrototypeFont- : WMProperties.FontProperty;
- StrComponent, StrVisualComponent, StrForm, StrFormWindow, StrModel, StrModelInfo : Strings.String;
- GSonStartDrag, GSonStartDragInfo : Strings.String;
- ModelPrototype-: WMProperties.ReferenceProperty;
- propertyListList- : PropertyListList;
- currentStyle- : XML.Element;
- componentStyleMsg- : ComponentStyleChanged;
- timestamp : LONGINT;
- macroHandlers : MacroHandler; (* the head of the list is always the DefaultMacroHandler *)
- selection-: SelectionList;
- (*
- PROCEDURE ResetInternal(parent:Component);
- VAR c: XML.Content;
- BEGIN
- IF ~parent.initialized THEN parent.Initialize END;
- (*parent.RecacheProperties;*)
- c := parent.GetFirst();
- WHILE (c # NIL) DO
- IF c IS Component THEN
- ResetInternal(c(Component))
- END;
- c := parent.GetNext(c);
- END;
- END ResetInternal;
- *)
- PROCEDURE IsWhiteSpace(ch : CHAR) : BOOLEAN;
- BEGIN
- RETURN ch <= " ";
- END IsWhiteSpace;
- PROCEDURE SkipWhiteSpace(CONST string : ARRAY OF CHAR; VAR index : LONGINT);
- VAR length : LONGINT;
- BEGIN
- length := LEN(string);
- WHILE (index < length) & (string[index] # 0X) & IsWhiteSpace(string[index]) DO INC(index); END;
- ASSERT(index < LEN(string));
- END SkipWhiteSpace;
- PROCEDURE ReadWord*(CONST string : ARRAY OF CHAR; VAR word : ARRAY OF CHAR; VAR index : LONGINT) : BOOLEAN;
- VAR length, wordLength, i : LONGINT;
- BEGIN
- SkipWhiteSpace(string, index);
- length := LEN(string);
- wordLength := LEN(word);
- i := 0;
- WHILE (index < length) & (string[index] # 0X) & ~IsWhiteSpace(string[index]) & (i < wordLength) DO
- word[i] := string[index];
- INC(i);
- INC(index);
- END;
- IF (i < wordLength) THEN word[i] := 0X; END;
- ASSERT(index < LEN(string));
- RETURN (i > 0) & (index < length) & (i < wordLength);
- END ReadWord;
- (* Split <string> into two strings separated by <separator> *)
- PROCEDURE SplitMacroString(CONST string : ARRAY OF CHAR; VAR namespace, name : ARRAY OF CHAR; separator : CHAR);
- VAR i, j : LONGINT;
- BEGIN
- ASSERT((LEN(namespace) >= LEN(string)) & (LEN(name) >= LEN(string)));
- i := 0;
- WHILE (i < LEN(string)) & (string[i] # 0X) & (string[i] # separator) DO
- namespace[i] := string[i];
- INC(i);
- END;
- namespace[i] := 0X;
- INC(i); (* skip separator *)
- j := 0;
- WHILE (i < LEN(string)) & (string[i] # 0X) DO
- name[j] := string[i];
- INC(i); INC(j);
- END;
- name[j] := 0X;
- IF (name = "") THEN COPY(namespace, name); COPY(NoNamespace, namespace); END; (* no namespace *)
- END SplitMacroString;
- PROCEDURE ReportError(CONST text, argument1, argument2 : ARRAY OF CHAR);
- VAR
- message : Events.Message;
- textIdx, messageIdx : LONGINT;
- secondArgument : BOOLEAN;
- PROCEDURE Append(VAR message : ARRAY OF CHAR; CONST argument : ARRAY OF CHAR; VAR index : LONGINT);
- VAR i : LONGINT;
- BEGIN
- i := 0;
- WHILE (i < LEN(argument)) & (argument[i] # 0X) & (index < LEN(message) - 1) DO
- message[index] := argument[i];
- INC(i);
- INC(index);
- END;
- END Append;
- BEGIN
- secondArgument := FALSE;
- textIdx := 0;
- messageIdx := 0;
- WHILE (textIdx < LEN(text)) & (text[textIdx] # 0X) & (messageIdx < LEN(message) - 1) DO
- IF (text[textIdx] # "%") THEN
- message[messageIdx] := text[textIdx];
- INC(messageIdx);
- ELSE
- IF ~secondArgument THEN
- secondArgument := TRUE;
- Append(message, argument1, messageIdx);
- ELSE
- Append(message, argument2, messageIdx);
- END;
- END;
- INC(textIdx);
- END;
- message[messageIdx] := 0X;
- Events.AddEvent("Components", Events.Error, 0, 0, 0, message, FALSE);
- END ReportError;
- PROCEDURE GetArgumentStream*(command: Strings.String; offset: LONGINT; VAR arguments: Streams.StringReader);
- VAR i: LONGINT;
- BEGIN
- IF command = NIL THEN arguments := NIL; RETURN END;
- i := offset;
- WHILE (i < LEN(command)) & (command[i] # 0X) DO INC(i); END;
- IF (i # offset) THEN
- NEW(arguments, i - offset + 1);
- arguments.SetRaw(command^, offset, i - offset + 1);
- ELSE
- arguments := NIL;
- END;
- END GetArgumentStream;
- PROCEDURE GenerateContext*(oldCommand, command : Strings.String; index : LONGINT; originator : Component; CONST event : Event) : EventContext;
- VAR
- context : EventContext; pointerContext : PointerContext; keyContext : KeyContext;
- arguments : Streams.StringReader;
- i : LONGINT;
- BEGIN
- ASSERT((command # NIL) & (0 <= index) & (index < LEN(command)));
- ASSERT(originator # NIL);
- GetArgumentStream(command,index,arguments);
- IF (event IS PointerEvent) THEN
- NEW(pointerContext, originator, oldCommand, NIL, arguments, NIL, NIL, NIL); pointerContext.pointer := event(PointerEvent);
- context := pointerContext;
- ELSIF (event IS KeyPressedEvent) THEN
- NEW(keyContext, originator, oldCommand, NIL, arguments, NIL, NIL, NIL); keyContext.key := event(KeyPressedEvent);
- context := keyContext;
- ELSE
- NEW(context, originator, oldCommand, NIL, arguments, NIL, NIL, NIL);
- END;
- BEGIN {EXCLUSIVE}
- context.timestamp := timestamp;
- INC(timestamp);
- END;
- ASSERT(context # NIL);
- RETURN context;
- END GenerateContext;
- PROCEDURE HandleEvent*(CONST event : Event; originator : Component; command : Strings.String);
- VAR
- commandString : ARRAY 128 OF CHAR;
- newCommand : Strings.String;
- context : EventContext;
- msg : Events.Message;
- index : LONGINT;
- BEGIN
- ASSERT((originator # NIL) & (command # NIL));
- index := 0;
- IF Logging THEN
- COPY(command^, msg);
- Events.AddEvent("Components", Events.Information, 0, 0, 0, msg, FALSE);
- END;
- SubstituteMacros(command, newCommand, originator);
- IF ReadWord(newCommand^, commandString, index) THEN
- context := GenerateContext(command, newCommand, index, originator, event);
- Commands.Activate(commandString, context, {}, context.result, msg); (* asynchronous call since holding the originators lock! *)
- IF (context.result # Commands.Ok) THEN
- Events.AddEvent("Components", Events.Error, 0, 0, 0, msg, FALSE);
- END;
- ELSE
- Events.AddEvent("Components", Events.Error, 0, 0, 0, "Expected command", FALSE);
- END;
- END HandleEvent;
- PROCEDURE ContainsMacros(CONST string : ARRAY OF CHAR) : BOOLEAN;
- VAR result : BOOLEAN; length, i : LONGINT;
- BEGIN
- result := FALSE;
- i := 0; length := LEN(string);
- WHILE (i < length) & (string[i] # 0X) & ~result DO
- IF (string[i] = MacroCharacter) THEN
- result := (i + 1 < length) & (string[i+1] # MacroCharacter);
- IF ~result THEN (* two consequent MacroCharacter's are used to escape *)
- INC(i); (*skip string[i+1] *)
- END;
- END;
- INC(i);
- END;
- RETURN result;
- END ContainsMacros;
- PROCEDURE WriteSelectionToStream(w : Streams.Writer);
- VAR text : Texts.Text; from, to : Texts.TextPosition; a, b : LONGINT;
- BEGIN
- ASSERT(w # NIL);
- IF Texts.GetLastSelection(text, from, to) THEN
- text.AcquireRead;
- a := Strings.Min(from.GetPosition(), to.GetPosition());
- b := Strings.Max(from.GetPosition(), to.GetPosition());
- IF (text.GetLength() > 0) THEN
- TextUtilities.SubTextToStream(text, a, b - a + 1, w);
- END;
- text.ReleaseRead;
- END;
- END WriteSelectionToStream;
- PROCEDURE SubstituteMacro(CONST command : Strings.String; VAR index : LONGINT; originator : Component; w : Streams.Writer);
- VAR oldIndex : LONGINT; macro, namespace, name : Macro; handler : MacroHandlerProcedure; handled : BOOLEAN;
- BEGIN
- ASSERT((command # NIL) & (0 <= index) & (index < LEN(command)) & (command[index] = MacroCharacter));
- ASSERT(originator # NIL);
- ASSERT(w # NIL);
- oldIndex := index;
- INC(index); (* skip MacroCharacter *)
- IF ReadWord(command^, macro, index) THEN (*? TBD error handling *)
- SplitMacroString(macro, namespace, name, NamespaceCharacter);
- IF (namespace = NoNamespace) OR (namespace = DefaultNamespace) THEN
- handler := DefaultMacroHandler;
- ELSE
- BEGIN {EXCLUSIVE}
- handler := FindMacroHandler(namespace);
- END;
- END;
- handled := FALSE;
- IF (handler # NIL) THEN handler(name, originator, w, handled); END;
- IF ~handled THEN
- w.Char(MacroCharacter); w.String(macro); (* don't substitute *)
- END;
- END;
- ASSERT(index > oldIndex);
- END SubstituteMacro;
- PROCEDURE SubstituteMacros*(CONST command : Strings.String; VAR newCommand : Strings.String; originator : Component);
- VAR index, oldIndex, length : LONGINT; w : Streams.Writer; buffer : Strings.Buffer;
- BEGIN
- ASSERT((command # NIL) & (originator # NIL));
- IF ContainsMacros(command^) THEN
- NEW(buffer, 256);
- w := buffer.GetWriter();
- index := 0; length := LEN(command^);
- WHILE (index < length) & (command[index] # 0X) DO
- oldIndex := index;
- IF (command[index] = MacroCharacter) THEN
- IF (index + 1 < length) & (command[index + 1] = MacroCharacter) THEN (* escape *)
- w.Char(MacroCharacter);
- index := index + 2; (* skip both MacroCharacter's *)
- ELSE
- (* substitute macro *)
- SubstituteMacro(command, index, originator, w);
- END;
- ELSE
- w.Char(command[index]);
- INC(index);
- END;
- ASSERT(index > oldIndex);
- END;
- newCommand := buffer.GetString();
- ELSE
- newCommand := command;
- END;
- ASSERT(newCommand # NIL);
- END SubstituteMacros;
- PROCEDURE GetAttributeValue(originator : Component; CONST fullname : ARRAY OF CHAR) : Strings.String;
- VAR value : Strings.String; c : Component; component, attribute : ARRAY 64 OF CHAR;
- BEGIN
- ASSERT(originator # NIL);
- value := NIL;
- Strings.GetExtension(fullname, component, attribute);
- IF (attribute = "") THEN
- COPY(component, attribute);
- COPY("", component);
- END;
- IF (component[0] = "@") THEN component[0] := "&"; END; (*? TBD: Hack to avoid ampersand in XML *)
- IF (component = "") THEN
- c := originator;
- ELSE
- c := originator.Find(component);
- END;
- IF (c # NIL) THEN
- IF c.HasAttribute(attribute) THEN
- RETURN c.GetAttributeValue(attribute);
- ELSE
- ReportError("Attribute % of component % not found", attribute, component);
- END;
- ELSE
- ReportError("Component % not found", component, "");
- END;
- RETURN value;
- END GetAttributeValue;
- PROCEDURE GetPropertyValue(originator : Component; CONST fullname : ARRAY OF CHAR) : Strings.String;
- VAR value : ARRAY 256 OF CHAR; string:Strings.String; c : Component; component, property : ARRAY 64 OF CHAR;
- BEGIN
- ASSERT(originator # NIL);
- Strings.GetExtension(fullname, component, property);
- IF (property = "") THEN COPY(component, property); COPY("", component);
- END;
- IF (component[0] = "@") THEN component[0] := "&"; END; (*? TBD: Hack to avoid ampersand in XML *)
- IF (component = "") THEN c := originator;
- ELSE c := originator.Find(component);
- END;
- IF (c # NIL) THEN
- IF c.properties.GetPropertyValue(property,value) THEN RETURN Strings.NewString(value)
- ELSE ReportError("Property % of component % not found", property, component);
- END;
- ELSE ReportError("Component % not found", component, "");
- END;
- RETURN NIL;
- END GetPropertyValue;
- PROCEDURE DefaultMacroHandler(CONST macro : Macro; originator : Component; w : Streams.Writer; VAR handled : BOOLEAN);
- VAR string, value : Strings.String;
- BEGIN
- ASSERT((originator # NIL) & (w # NIL));
- handled := TRUE;
- IF (macro = MacroSelection) THEN
- WriteSelectionToStream(w);
- ELSIF (macro = MacroClipboard) THEN
- TextUtilities.TextToStream(Texts.clipboard, w);
- ELSIF Strings.StartsWith(MacroAttributePrefix, 0, macro) THEN
- string := Strings.Substring(Strings.Length(MacroAttributePrefix), Strings.Length(macro), macro);
- value := GetAttributeValue(originator, string^);
- IF (value # NIL) THEN
- w.String(value^);
- ELSE
- handled := FALSE;
- END;
- ELSIF Strings.StartsWith(MacroPropertyPrefix, 0, macro) THEN
- string := Strings.Substring(Strings.Length(MacroPropertyPrefix), Strings.Length(macro), macro);
- value := GetPropertyValue(originator,string^);
- IF (value # NIL) THEN
- w.String(value^);
- ELSE
- handled := FALSE;
- END;
- ELSE
- handled := FALSE;
- END;
- END DefaultMacroHandler;
- PROCEDURE FindMacroHandler(CONST namespace : ARRAY OF CHAR) : MacroHandlerProcedure;
- VAR node : MacroHandler; handler : MacroHandlerProcedure;
- BEGIN (* caller must hold module lock! *)
- node := macroHandlers;
- WHILE (node # NIL) & (node.namespace # namespace) DO node := node.next; END;
- IF (node # NIL) THEN
- handler := node.handler;
- ELSE
- handler := NIL;
- END;
- RETURN handler;
- END FindMacroHandler;
- PROCEDURE AddMacroHandler*(CONST namespace : Namespace; handler : MacroHandlerProcedure; VAR res : LONGINT);
- VAR new, node : MacroHandler; h : MacroHandlerProcedure;
- BEGIN {EXCLUSIVE}
- ASSERT((namespace # NoNamespace) & (handler # NIL));
- ASSERT(macroHandlers # NIL);
- h := FindMacroHandler(namespace);
- IF (h = NIL) THEN (* append new handler to list *)
- NEW(new);
- new.handler := handler;
- new.namespace := namespace;
- new.next := NIL;
- node := macroHandlers;
- WHILE (node.next # NIL) DO node := node.next; END;
- node.next := new;
- res := Ok;
- ELSE
- res := DuplicateNamespace;
- END;
- END AddMacroHandler;
- PROCEDURE RemoveMacroHandler*(handler : MacroHandlerProcedure);
- VAR node : MacroHandler;
- BEGIN {EXCLUSIVE}
- ASSERT((handler # NIL) & (handler # DefaultMacroHandler));
- ASSERT(macroHandlers # NIL);
- node := macroHandlers;
- WHILE (node.next # NIL) & (node.next.handler # handler) DO node := node.next; END;
- ASSERT((node.next # NIL) & (node.next.handler = handler));
- node.next := node.next.next;
- END RemoveMacroHandler;
- PROCEDURE SetAttribute*(context : Commands.Context); (** component attribute value ~ *)
- VAR originator, target : Component; name, attribute, value : ARRAY 128 OF CHAR; (*? TBD array size *)
- BEGIN
- IF (context IS EventContext) THEN
- originator := context(EventContext).originator;
- IF context.arg.GetString(name) & context.arg.GetString(attribute) & context.arg.GetString(value) THEN
- target := originator.Find(name);
- IF (target # NIL) THEN
- IF target.HasAttribute(attribute) THEN
- target.SetAttributeValue(attribute, value);
- ELSE
- context.result := Commands.CommandError;
- END;
- ELSE
- context.result := Commands.CommandError;
- END;
- ELSE
- context.error.String("Expected component name, attribute and value parameters"); context.error.Ln;
- context.result := Commands.CommandParseError;
- END;
- ELSE
- context.error.String("Command requires EventContext."); context.error.Ln;
- context.result := Commands.CommandParseError;
- END;
- END SetAttribute;
- (** Activate a string of commands, including their parameters.
- The string is parsed from left to right and Activate is called for every command.
- Parsing stops at the end of the string, or when Activate returns an error.
- The flags are applied to every command, i.e., for sequential execution,
- use the Wait flag (the caller waits until all commands return).
- Syntax:
- cmds = [mode " " ] cmd {";" cmd} .
- mode = "PAR" | "SEQ" .
- cmd = mod ["." proc] [" " params] .
- params = {<any character except ";">} .
- REMARK: For now, this is almost the same as Commands.Call. This procedure will either be enhanced to
- support some component-related macro substitution or be replaced by Commands.Call
- *)
- PROCEDURE Call*(cmds : ARRAY OF CHAR; caller : Component; flags : SET; VAR res : LONGINT; VAR msg : ARRAY OF CHAR);
- VAR
- context : Commands.Context; arg : Streams.StringReader;
- buffer : Strings.Buffer; w : Streams.Writer; par : Strings.String;
- length, i, k : LONGINT;
- PROCEDURE Expand(CONST string : ARRAY OF CHAR; w : Streams.Writer; start : LONGINT; VAR end : LONGINT);
- VAR
- component : Component;
- componentStr, attributeStr : ARRAY 256 OF CHAR;
- property : WMProperties.Property; attribute : XML.Attribute;
- value : Strings.String;
- lastDotIdx, i, j : LONGINT; error : BOOLEAN;
- BEGIN
- ASSERT((string[start] = "&") & (start + 1 < LEN(string)) & (w # NIL));
- end := start; WHILE (end < LEN(string)) & (string[end] # 0X) & (string[end] # ";") & (string[end] > " ") DO INC(end); END;
- DEC(end);
- lastDotIdx := end;
- WHILE (lastDotIdx > start) & (string[lastDotIdx] # ".") DO DEC(lastDotIdx); END;
- error := (lastDotIdx <= start); (* missing dot *)
- IF ~error THEN
- i := start + 1; (* skip ampersand *)
- IF (string[i] = "&") OR (string[i] = "/") THEN
- j := 0;
- WHILE (i < lastDotIdx) & (j < LEN(componentStr) - 1) DO
- componentStr[j] := string[i];
- INC(i); INC(j);
- END;
- componentStr[j] := 0X;
- component := caller.Find(componentStr);
- ELSE
- componentStr := "";
- component := caller;
- END;
- ASSERT(string[i] = ".");
- INC(i); (* skip dot *)
- attributeStr := "";
- j := 0;
- WHILE (j < LEN(attributeStr)) & (i <= end) DO
- attributeStr[j] := string[i];
- INC(i); INC(j);
- END;
- error := (attributeStr = "");
- IF ~error THEN
- IF (component # NIL) THEN
- property := component.properties.Get(attributeStr);
- IF (property # NIL) THEN
- property.ToStream(w);
- ELSE
- attribute := component.GetAttribute(attributeStr);
- IF (attribute # NIL) THEN
- value := attribute.GetValue();
- IF (value # NIL) THEN w.String(value^); ELSE w.String("NIL"); END;
- ELSE
- error := TRUE;
- END;
- END;
- ELSE
- error := TRUE;
- END;
- END;
- END;
- IF error THEN (* don't expand macro *)
- FOR i := start TO end DO w.Char(string[i]); END;
- END;
- ASSERT(end >= start);
- END Expand;
- BEGIN
- ASSERT(caller # NIL);
- NEW(buffer, LEN(cmds)); w := buffer.GetWriter();
- IF Strings.StartsWith2(Repositories.CommandPrefix, cmds) THEN i := Strings.Length(Repositories.CommandPrefix); ELSE i := 0; END;
- LOOP
- buffer.Clear;
- w.Reset;
- k := 0;
- WHILE (i < LEN(cmds)) & (cmds[i] # " ") & (cmds[i] # 09X) & (cmds[i] # 0DX) & (cmds[i] # 0AX) & (cmds[i] # 0X) & (cmds[i] # ";") DO cmds[k] := cmds[i]; INC(k); INC(i); END;
- IF k = 0 THEN EXIT; END; (* end of string *)
- IF (i < LEN(cmds)) & (cmds[i] # ";") & (cmds[i] # 0X) THEN (* parameters *)
- INC(i); (* skip delimiter *)
- WHILE (i < LEN(cmds)) & (cmds[i] # 0X) & (cmds[i] # ";") DO
- IF (cmds[i] = "&") & (i + 1 < LEN(cmds)) & ((cmds[i+1] = "&") OR (cmds[i+1] = ".") OR (cmds[i+1] = "/")) THEN
- Expand(cmds, w, i, i);
- ELSE
- w.Char(cmds[i]);
- END;
- INC(i);
- END;
- END;
- IF (i < LEN(cmds)) & (cmds[i] = ";") THEN (* skip command delimiter *) INC(i); END;
- cmds[k] := 0X;
- length := buffer.GetLength();
- IF (length > 0) THEN
- par := buffer.GetString();
- NEW(arg, length + 1); arg.SetRaw(par^, 0, length + 1);
- ELSE
- arg := NIL;
- END;
- NEW(context, NIL, arg, NIL, NIL, caller);
- Commands.Activate(cmds, context, flags, res, msg);
- IF (res # Commands.Ok) THEN KernelLog.String("WMComponents.Call error, res = "); KernelLog.Int(res, 0); KernelLog.Ln; EXIT; END;
- END;
- END Call;
- PROCEDURE GetComponent*(CONST name : ARRAY OF CHAR) : Component;
- VAR component : Component; c : Repositories.Component; res : LONGINT;
- BEGIN
- component := NIL;
- Repositories.GetComponentByString(name, c, res);
- IF (res = Repositories.Ok) THEN
- IF (c # NIL) & (c IS Component) THEN
- component := c (Component);
- ELSE
- KernelLog.String("WMComponents.GetComponent: Could not generate component ");
- KernelLog.String(name); KernelLog.String(": Wrong type"); KernelLog.Ln;
- END;
- ELSE
- KernelLog.String("WMComponents.GetComponent: Could not generate component ");
- KernelLog.String(name); KernelLog.String(", res: "); KernelLog.Int(res, 0); KernelLog.Ln;
- END;
- RETURN component;
- END GetComponent;
- PROCEDURE GetVisualComponent*(CONST name : ARRAY OF CHAR) : VisualComponent;
- VAR component : VisualComponent; c : Repositories.Component; res : LONGINT;
- BEGIN
- component := NIL;
- Repositories.GetComponentByString(name, c, res);
- IF (res = Repositories.Ok) THEN
- IF (c # NIL) & (c IS VisualComponent) THEN
- component := c (VisualComponent);
- ELSE
- KernelLog.String("WMComponents.GetVisualComponent: Could not generate component ");
- KernelLog.String(name); KernelLog.String(": Wrong type"); KernelLog.Ln;
- END;
- ELSE
- KernelLog.String("WMComponents.GetVisualComponent: Could not generate component ");
- KernelLog.String(name); KernelLog.String(", res: "); KernelLog.Int(res, 0); KernelLog.Ln;
- END;
- RETURN component;
- END GetVisualComponent;
- PROCEDURE SetStyle*(style : XML.Element);
- BEGIN
- SetStyleInternal(style)
- END SetStyle;
- PROCEDURE SetStyleInternal(style : XML.Element);
- VAR msg : Messages.Message; m : WM.WindowManager;
- BEGIN
- currentStyle := style;
- IF propertyListList # NIL THEN propertyListList.UpdateStyle END;
- msg.msgType := Messages.MsgExt; msg.ext := componentStyleMsg;
- m := WM.GetDefaultManager();
- m.Broadcast(msg)
- END SetStyleInternal;
- PROCEDURE FindRelativePath(x : Component; CONST path : ARRAY OF CHAR; pos : LONGINT) : Component;
- VAR c : XML.Content;
- sn : ARRAY MaxComponentNameSize OF CHAR;
- i : LONGINT; id : Strings.String;
- BEGIN
- IF x = NIL THEN RETURN NIL
- ELSIF path[pos] = 0X THEN RETURN x
- ELSIF (pos = 0) & (path[0] = "/") THEN RETURN FindRelativePath(x.GetComponentRoot(), path, pos + 1)
- ELSIF (path[pos] = ".") & (path[pos + 1] = ".") THEN
- INC(pos, 2); IF path[pos]="/" THEN INC(pos) END;
- c := x.GetParent();
- IF (c # NIL) & (c IS Component) THEN
- RETURN FindRelativePath(c(Component), path, pos)
- ELSE
- RETURN NIL
- END
- ELSE
- i := 0; WHILE (i < MaxComponentNameSize - 1) & (path[pos] # 0X) & (path[pos] # "/") DO
- sn[i] := path[pos]; INC(i); INC(pos)
- END;
- IF (path[pos] = "/") THEN INC(pos) END;
- sn[i] := 0X;
- c := x.GetFirst();
- WHILE (c # NIL) DO
- IF (c IS Component) THEN
- id := c(Component).id.Get();
- IF (id # NIL) & (id^ = sn) THEN
- RETURN FindRelativePath(c(Component), path, pos);
- END;
- END;
- c := x.GetNext(c);
- END;
- RETURN NIL
- END
- END FindRelativePath;
- (* Report errors while parsing *)
- PROCEDURE Error(pos, line, row: LONGINT; CONST msg: ARRAY OF CHAR);
- BEGIN
- KernelLog.String("Parse error at pos "); KernelLog.Int(pos, 5); KernelLog.String(" in line "); KernelLog.Int(line, 5);
- KernelLog.String(" row "); KernelLog.Int(row, 5); KernelLog.String(" - "); KernelLog.String(msg); KernelLog.Ln;
- hasErrors := TRUE
- END Error;
- (** Load an XML file. Return NIL if errors occured *)
- PROCEDURE Load*(CONST filename : ARRAY OF CHAR) : XML.Content;
- VAR scanner : XMLScanner.Scanner;
- parser : XMLParser.Parser;
- doc : XML.Document;
- in : Streams.Reader;
- BEGIN {EXCLUSIVE}
- hasErrors := FALSE;
- in := Codecs.OpenInputStream(filename);
- IF in # NIL THEN
- NEW(scanner, in); scanner.reportError := Error;
- NEW(parser, scanner); parser.reportError := Error;
- parser.elemReg := Repositories.registry; doc := parser.Parse();
- IF hasErrors THEN RETURN NIL END;
- RETURN doc.GetRoot()
- END;
- RETURN NIL
- END Load;
- PROCEDURE FormWindowGen*(xml:XML.Content): WM.Window;
- VAR winx: XML.Element; formx: XML.Content; window: FormWindow; name, string:Strings.String; canvas:WMGraphics.BufferCanvas;
- canvasGenerator: WMGraphics.CanvasGenerator;
- moduleName, procedureName : Modules.Name;
- msg : ARRAY 128 OF CHAR;
- res: LONGINT;
- l,t,r,b: LONGINT;
- BEGIN
- IF xml IS XML.Element THEN
- winx:=xml(XML.Element);
- string:=winx.GetName();
- IF string^="FormWindow" THEN
- string:=winx.GetAttributeValue("l"); Strings.StrToInt(string^,l);
- string:=winx.GetAttributeValue("t"); Strings.StrToInt(string^,t);
- string:=winx.GetAttributeValue("r"); Strings.StrToInt(string^,r);
- string:=winx.GetAttributeValue("b"); Strings.StrToInt(string^,b);
- NEW(window, r-l, b-t, TRUE);
- name:=winx.GetAttributeValue("name"); window.SetTitle(name);
- window.bounds.r:=r; window.bounds.l:=l; window.bounds.t:=t; window.bounds.b:=b;
- string:=winx.GetAttributeValue("flags"); Strings.StrToSet(string^,window.flags);
- string:=winx.GetAttributeValue("canvasGenerator"); (* allow to plug in alternative canvas versions,e.g. WMGraphicsGfx.Canvas *)
- IF (string#NIL) THEN
- Commands.Split(string^, moduleName, procedureName, res, msg);
- IF (res = Commands.Ok) THEN
- GETPROCEDURE(moduleName, procedureName, canvasGenerator);
- IF (canvasGenerator # NIL) THEN
- window.SetCanvasGenerator(canvasGenerator);
- END;
- END;
- END;
-
- formx:=winx.GetFirst(); (* this typically has name="Form" *)
- IF (formx#NIL)&(formx IS XML.Element) THEN
- window.LoadComponents(formx(XML.Element)); (* at the price of duplication of component tree construction ...*)
- window.form.Reset(NIL,NIL);
- ELSE window:=NIL;
- END;
- END;
- END;
- RETURN window
- END FormWindowGen;
- (* generic loading of any form window using the generator procedure supplied in the XML as 'loader' attribute *)
- PROCEDURE LoadFormWindow*(xml:XML.Content): WM.Window;
- VAR winx: XML.Element; window: WM.Window; formWindow:FormWindow;
- formx, c:Component;
- name, string, load:Strings.String;
- moduleName, procedureName : Modules.Name;
- msg : ARRAY 128 OF CHAR;
- res: LONGINT;
- gen:WindowGenerator;
- bounds:Rectangles.Rectangle;
- BEGIN
- IF xml IS XML.Element THEN
- winx:=xml(XML.Element);
- name:=winx.GetName();
- IF name^="FormWindow" THEN
- string:=winx.GetAttributeValue("loader");
- Commands.Split(string^, moduleName, procedureName, res, msg);
- IF (res = Commands.Ok) THEN
- GETPROCEDURE(moduleName, procedureName, gen);
- IF (gen # NIL) THEN
- window:=gen(xml);
- END;
- END;
- ELSE (*generate FormWindow from generic Visual Component*)
- c:=ComponentFromXML(xml(XML.Element));
- IF (c#NIL) & (c IS VisualComponent) THEN
- bounds:=c(VisualComponent).bounds.Get();
- NEW(formWindow, bounds.r-bounds.l, bounds.b-bounds.t, TRUE);
- formWindow.SetContent(c);
- (*formWindow.SetTitle(c.GetName());*)
- window:=formWindow;
- END;
- END;
- END;
- RETURN window
- END LoadFormWindow;
- (** Open form window and build its component tree *)
- PROCEDURE Open*(context : Commands.Context);
- VAR filename: Files.FileName; window: WM.Window; xml:XML.Content;
- BEGIN
- IF context.arg.GetString(filename) & (Strings.Length(filename)>0) THEN
- xml:=Load(filename); (* here, the xml tree is already constructed, however not in the right sequence for component contruction ( [Init()..loadProperties()..Initialize()] )*)
- window:=LoadFormWindow(xml);
- IF window#NIL THEN
- WM.AddWindow(window,window.bounds.l,window.bounds.t);
- END;
- END;
- END Open;
- PROCEDURE LoadStyleInternal(CONST filename : ARRAY OF CHAR);
- VAR f : Files.File;
- scanner : XMLScanner.Scanner;
- parser : XMLParser.Parser;
- reader : Files.Reader;
- doc : XML.Document;
- BEGIN
- hasErrors := FALSE;
- f := Files.Old(filename);
- IF f # NIL THEN
- NEW(reader, f, 0);
- NEW(scanner, reader); scanner.reportError := Error;
- NEW(parser, scanner); parser.reportError := Error;
- parser.elemReg := Repositories.registry; doc := parser.Parse();
- IF hasErrors THEN KernelLog.String("Stylefile not ok"); KernelLog.Ln
- ELSE
- SetStyleInternal(doc.GetRoot())
- END
- END
- END LoadStyleInternal;
- (** Load Component registry file. Return NIL if errors occured *)
- PROCEDURE LoadStyle*(context : Commands.Context);
- VAR filename : ARRAY 64 OF CHAR;
- BEGIN {EXCLUSIVE}
- IF context.arg.GetString(filename) THEN
- LoadStyleInternal(filename);
- ELSE
- context.result := Commands.CommandParseError;
- END;
- END LoadStyle;
- PROCEDURE NewString*(CONST x : ARRAY OF CHAR) : Strings.String;
- VAR t : Strings.String;
- BEGIN
- NEW(t, LEN(x)); COPY(x, t^); RETURN t
- END NewString;
- PROCEDURE InitStrings;
- BEGIN
- StrComponent := NewString("Component");
- StrVisualComponent := NewString("VisualComponent");
- StrForm := NewString("Form");
- StrFormWindow := NewString("FormWindow");
- GSonStartDrag := NewString("onStartDrag");
- GSonStartDragInfo := NewString("Event generated whenever a drag is started");
- StrModel := NewString("Model");
- StrModelInfo := NewString("Model used by component");
- END InitStrings;
- PROCEDURE InitPrototypes;
- BEGIN
- (* General component properties *)
- NEW(PrototypeID, NIL, NewString("ID"),
- NewString("identifier of the component"));
- NEW(PrototypeUID, NIL, NewString("UID"),
- NewString("unique identifier of the component"));
- NEW(PrototypeEnabled, NIL, NewString("Enabled"),
- NewString("defines if the component is enabled"));
- PrototypeEnabled.Set(TRUE);
- (* Visual component properties *)
- NEW(PrototypeBounds, NIL, NewString("Bounds"),
- NewString("the bounding box of the component in parent coordinates"));
- NEW(PrototypeBoundsRelative, NIL, NewString("RelBounds"),
- NewString("the bounding box of the component in relative parent coordinates"));
- NEW(PrototypeBearing, NIL, NewString("Bearing"),
- NewString("the bearing (empty space) aroung the component if auto aligned"));
- NEW(PrototypeFillColor, NIL, NewString("FillColor"),
- NewString("the main fill color of the component. i.e. background"));
- NEW(PrototypeAlignment, NIL, NewString("Alignment"),
- NewString("defines the alignment none, left, right, top, bottom or client"));
- PrototypeAlignment.Set(0);
- NEW(PrototypeVisible, NIL, NewString("Visible"),
- NewString("defines if the component is visible"));
- PrototypeVisible.Set(TRUE);
- NEW(PrototypeTakesFocus, NIL, NewString("TakesFocus"),
- NewString("defines if the component takes the keyboard focus"));
- NEW(PrototypeNeedsTab, NIL, NewString("NeedsTab"),
- NewString("defines if the component handles the tabulator key"));
- NEW(PrototypeFocusPrevious, NIL, NewString("FocusPrevious"), NewString("Previous focus component ID"));
- PrototypeFocusPrevious.Set(NIL);
- NEW(PrototypeFocusNext, NIL, NewString("FocusNext"), NewString("Next focus component ID"));
- PrototypeFocusNext.Set(NIL);
- NEW(PrototypeEditMode, NIL, NewString("EditMode"), NewString("defines if the contents of the component can be edited"));
- PrototypeEditMode.Set(FALSE);
- NEW(PrototypeFont, NIL, NewString("Font"), NewString("Font"));
- PrototypeFont.Set(WMGraphics.GetDefaultFont());
- NEW(PrototypeScaleFont, NIL, Strings.NewString("ScaleFont"), Strings.NewString("percentage that fonts scales with height (0=none)"));
- NEW(ModelPrototype, NIL, StrModel, StrModelInfo);
- END InitPrototypes;
- PROCEDURE ShowComponent(component : Component);
- VAR string : Strings.String;
- BEGIN
- IF (component # NIL) THEN
- string := component.GetName();
- IF (string # NIL) THEN KernelLog.String(string^); ELSE KernelLog.String("NoName"); END;
- KernelLog.String(" [");
- string := component.uid.Get();
- IF (string # NIL) THEN KernelLog.String(string^); ELSE KernelLog.String("NIL"); END;
- IF (component IS VisualComponent) THEN
- KernelLog.String(", "); KernelLog.Boolean(component(VisualComponent).takesFocus.Get());
- END;
- KernelLog.String("]");
- ELSE
- KernelLog.String("NIL?");
- END;
- END ShowComponent;
- PROCEDURE NewLine(w : Streams.Writer; level : LONGINT);
- BEGIN
- w.Ln; WHILE level > 0 DO w.Char(09X); DEC(level) END
- END NewLine;
- PROCEDURE InstallDefaultMacroHandler;
- BEGIN
- NEW(macroHandlers);
- macroHandlers.handler := DefaultMacroHandler;
- macroHandlers.namespace := DefaultNamespace;
- macroHandlers.next := NIL;
- END InstallDefaultMacroHandler;
- (*! ---- xml tool --- move to where appropriate *)
- PROCEDURE GetElementByName(parent : XML.Element; CONST name : ARRAY OF CHAR) : XML.Element;
- VAR elem : XML.Element; enum : XMLObjects.Enumerator; ptr : ANY; string : Strings.String;
- BEGIN
- IF parent # NIL THEN
- enum := parent.GetContents(); enum.Reset();
- WHILE enum.HasMoreElements() DO
- ptr := enum.GetNext();
- IF ptr IS XML.Element THEN
- elem := ptr (XML.Element);
- string := elem.GetName();
- IF (string # NIL) & (string^ = name) THEN
- RETURN elem;
- END;
- END;
- END;
- END;
- RETURN NIL;
- END GetElementByName;
- PROCEDURE NewComponent*(): XML.Element;
- VAR component: Component;
- BEGIN NEW(component); RETURN component;
- END NewComponent;
- PROCEDURE NewVisualComponent*(): XML.Element;
- VAR component: VisualComponent;
- BEGIN NEW(component); RETURN component;
- END NewVisualComponent;
- (* does not work like this its own because a form is statically bound to a window, but for completeness.. *)
- PROCEDURE NewForm*(): XML.Element;
- VAR component: Form;
- BEGIN NEW(component, NIL); RETURN component
- END NewForm;
- PROCEDURE Align*(context: Commands.Context);
- VAR width,height,bwidth,bheight: LONGINT; entry: ComponentListEntry; b,rect: Rectangles.Rectangle; string: ARRAY 32 OF CHAR; l,t: LONGINT; done: BOOLEAN;
- BEGIN
- entry := selection.first;
- rect.l := MAX(LONGINT); rect.r := MIN(LONGINT);
- rect.t := MAX(LONGINT); rect.b := MIN(LONGINT);
- width := 0; height := 0;
- WHILE entry # NIL DO
- b := entry.component.bounds.Get();
- bwidth := b.r-b.l; bheight := b.b-b.t;
- IF b.l < rect.l THEN rect.l := b.l END;
- IF b.r > rect.r THEN rect.r := b.r END;
- IF b.t < rect.t THEN rect.t := b.t END;
- IF b.b > rect.b THEN rect.b := b.b END;
- IF width < bwidth THEN width := bwidth END;
- IF height < bheight THEN height := bheight END;
- entry := entry.next
- END;
- done := FALSE;
- WHILE ~done & context.arg.GetString(string) DO
- l := rect.l; t := rect.t;
- entry := selection.first;
- WHILE ~done & (entry # NIL) DO
- b := entry.component.bounds.Get(); bwidth := b.r-b.l; bheight := b.b-b.t;
- entry.component.AdaptRelativeBounds(b,entry.component.GetParent());
- IF string = "left" THEN b.l := rect.l; b.r := rect.l + bwidth;
- ELSIF string = "right" THEN b.r := rect.r; b.l := rect.r-bwidth
- ELSIF string = "top" THEN b.t := rect.t; b.b := rect.t + bheight;
- ELSIF string = "bottom" THEN b.b := rect.b; b.t := rect.b-bheight
- ELSIF string = "width" THEN b.r := b.l + width;
- ELSIF string = "height" THEN b.b := b.t + height;
- ELSIF string = "size" THEN b.r := b.l + width; b.b := b.t + height;
- ELSIF string = "hcenter" THEN b.l := (rect.l+rect.r) DIV 2 - bwidth DIV 2; b.r := b.l + bwidth;
- ELSIF string = "vcenter" THEN b.t := (rect.t + rect.b) DIV 2 - bheight DIV 2; b.b := b.t + bheight;
- ELSIF string = "horizontal" THEN b.l := l; b.r := b.l + bwidth; l := b.r+1
- ELSIF string = "vertical" THEN b.t := t; b.b := b.t + bheight; t := b.b + 1;
- ELSIF string = "none" THEN entry.component.alignment.Set(AlignNone)
- ELSIF string = "relative" THEN entry.component.alignment.Set(AlignRelative)
- ELSE done := TRUE
- END;
- entry.component.AdaptRelativeBounds(b,entry.component.GetParent());
- entry.component.bounds.Set(b);
- entry := entry.next
- END;
- END;
- END Align;
- PROCEDURE SetProperty*(context: Commands.Context);
- VAR name, value: ARRAY 256 OF CHAR; entry: ComponentListEntry;
- BEGIN
- IF context.arg.GetString(name) & context.arg.GetString(value) THEN
- entry := selection.first;
- WHILE entry # NIL DO
- IF entry.component.properties.SetPropertyValue(name, value) THEN END;
- entry := entry.next;
- END;
- END;
- END SetProperty;
- PROCEDURE RemoveSelection*;
- VAR entry: ComponentListEntry; parent: XML.Element;
- BEGIN
- entry := selection.first;
- WHILE entry # NIL DO
- parent := entry.component.GetParent();
- IF parent # NIL THEN parent(VisualComponent).RemoveContent(entry.component); parent(VisualComponent).Invalidate END;
- entry := entry.next
- END;
- END RemoveSelection;
- PROCEDURE ComponentFromXML*(xml: XML.Element): Component;
- VAR generator: PROCEDURE(): XML.Element;
- VAR
- l,name: Strings.String;
- moduleName, procedureName: Modules.Name;
- res: LONGINT; msg: ARRAY 32 OF CHAR;
- component: Component;
- element: XML.Element;
- BEGIN
- component := NIL;
- IF xml # NIL THEN
- name := xml.GetName();
- l := xml.GetAttributeValue("generator");
- IF l # NIL THEN
- Commands.Split(l^, moduleName, procedureName, res, msg);
- IF (res = Commands.Ok) THEN
- GETPROCEDURE(moduleName, procedureName, generator);
- IF (generator # NIL) THEN
- element := generator();
- IF (element # NIL) & (element IS Component) THEN
- component := element(Component);
- component.SetName(name^);
- component.FromXML(xml);
- END;
- ELSE KernelLog.String("WMComponents error: invalid generator "); KernelLog.String(l^); KernelLog.Ln;
- END;
- ELSE KernelLog.String("WMComponents error: could not generate component "); KernelLog.String(l^); KernelLog.Ln;
- END;
- END;
- END;
- RETURN component
- END ComponentFromXML;
- PROCEDURE Clone*(x: Component): Repositories.Component;
- BEGIN
- RETURN ComponentFromXML(x)
- END Clone;
- BEGIN
- timestamp := 0;
- NEW(componentStyleMsg);
- NEW(propertyListList);
- InitStrings;
- InitPrototypes;
- NEW(invalidateRectMsg);
- InstallDefaultMacroHandler;
- NEW(selection);
- END WMComponents.
- WMComponents.Open FigureExample.Cwd ~
- WMComponents.Open DictEntry.wm ~
- The message sequencer contains a reader writer lock that can be used to block the hierarchy.
- Each message-call from the sequencer posesses the writer lock.
- WMComponents.LoadStyle ComponentStyle.XML ~
- If a focusComponent is set in an non-focus container-component, the focus can not escape the "isolated" component group
|