1 (* coded by Ketmar // Invisible Vector <ketmar@ketmar.no-ip.org>
2 * Understanding is not required. Only obedience.
4 * This program is free software: you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation, either version 3 of the License, or
7 * (at your option) any later version.
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
14 * You should have received a copy of the GNU General Public License
15 * along with this program. If not, see <http://www.gnu.org/licenses/>.
17 {$INCLUDE ../../shared/a_modes.inc}
25 xstreams
, xparser
, utils
, hashtable
;
29 TStyleValue
= packed record
31 type TType
= (Empty
, Bool
, Int
, Color
);
34 constructor Create (v
: Boolean; okToInherit
: Boolean=true);
35 constructor Create (v
: Integer; okToInherit
: Boolean=true);
36 constructor Create (ar
, ag
, ab
: Integer; okToInherit
: Boolean=true);
37 constructor Create (ar
, ag
, ab
, aa
: Integer; okToInherit
: Boolean=true);
38 constructor Create (const v
: TGxRGBA
; okToInherit
: Boolean=true);
40 function isEmpty (): Boolean; inline;
41 function canInherit (): Boolean; inline;
43 function toString (): AnsiString;
44 function asRGBA
: TGxRGBA
; inline;
45 function asRGBADef (const def
: TGxRGBA
): TGxRGBA
; inline;
46 function asIntDef (const def
: Integer): Integer; inline;
47 function asBoolDef (const def
: Boolean): Boolean; inline;
51 allowInherit
: Boolean;
53 TType
.Bool
: (bval
: Boolean);
54 TType
.Int
: (ival
: Integer);
55 TType
.Color
: (r
, g
, b
, a
: Byte);
58 TStyleSection
= class;
60 THashStrStyleVal
= specialize THashBase
<AnsiString, TStyleValue
, THashKeyStrAnsiCI
>;
61 THashStrSection
= specialize THashBase
<AnsiString, TStyleSection
, THashKeyStrAnsiCI
>;
65 mVals
: THashStrStyleVal
;
66 mHashVals
: THashStrSection
; // "#..."
67 mCtlVals
: THashStrSection
;
70 // "text-color#inactive@label"
71 function getValue (const path
: AnsiString): TStyleValue
;
72 procedure setValue (const path
: AnsiString; const val
: TStyleValue
);
75 constructor Create ();
76 destructor Destroy (); override;
79 property value
[const path
: AnsiString]: TStyleValue read getValue write setValue
; default
;
84 mId
: AnsiString; // style name ('default', for example)
88 procedure parse (par
: TTextParser
);
90 function getValue (const path
: AnsiString): TStyleValue
; inline;
91 procedure setValue (const path
: AnsiString; const val
: TStyleValue
); inline;
94 constructor Create (const aid
: AnsiString);
95 constructor Create (st
: TStream
); // parse from stream
96 constructor CreateFromFile (const fname
: AnsiString);
97 destructor Destroy (); override;
100 property id
: AnsiString read mId
;
101 property value
[const path
: AnsiString]: TStyleValue read getValue write setValue
; default
;
105 procedure uiLoadStyles (const fname
: AnsiString);
106 procedure uiLoadStyles (st
: TStream
);
108 // will return "default" (or raise an exception if there is no "default")
109 function uiFindStyle (const stname
: AnsiString): TUIStyle
;
115 // ////////////////////////////////////////////////////////////////////////// //
117 styles
: array of TUIStyle
= nil;
120 function createDefaultStyle (): TUIStyle
;
122 result
:= TUIStyle
.Create('default');
124 result
['back-color'] := TStyleValue
.Create(TGxRGBA
.Create(0, 0, 128));
125 result
['text-color'] := TStyleValue
.Create(TGxRGBA
.Create(255, 255, 255));
126 result
['frame-color'] := TStyleValue
.Create(TGxRGBA
.Create(255, 255, 255));
127 result
['frame-text-color'] := TStyleValue
.Create(TGxRGBA
.Create(255, 255, 255));
128 result
['frame-icon-color'] := TStyleValue
.Create(TGxRGBA
.Create(0, 255, 0));
130 // disabled is always inactive too
133 result
['back-color#disabled'] := TStyleValue
.Create(TGxRGBA
.Create(0, 0, 127));
134 result
['text-color#disabled'] := TStyleValue
.Create(TGxRGBA
.Create(127, 127, 127));
135 result
['frame-text-color#disabled'] := TStyleValue
.Create(TGxRGBA
.Create(127, 127, 127));
136 result
['frame-icon-color#disabled'] := TStyleValue
.Create(TGxRGBA
.Create(0, 127, 0));
137 result
['darken#disabled'] := TStyleValue
.Create(128, false); // darken inactive windows, no-inherit
138 result
['darken#inactive'] := TStyleValue
.Create(128, false); // darken inactive windows, no-inherit
141 result
['text-color@label'] := TStyleValue
.Create(TGxRGBA
.Create(255, 255, 255));
142 result
['text-color#disabled@label'] := TStyleValue
.Create(TGxRGBA
.Create(127, 127, 127));
145 result
['frame-color@box'] := TStyleValue
.Create(TGxRGBA
.Create(255, 255, 0));
146 result
['frame-text-color@box'] := TStyleValue
.Create(TGxRGBA
.Create(255, 255, 0));
147 result
['frame-icon-color@box'] := TStyleValue
.Create(TGxRGBA
.Create(0, 255, 0));
149 result
['frame-color#inactive@box'] := TStyleValue
.Create(TGxRGBA
.Create(255, 255, 255));
150 result
['frame-text-color#inactive@box'] := TStyleValue
.Create(TGxRGBA
.Create(255, 255, 255));
151 result
['frame-icon-color#inactive@box'] := TStyleValue
.Create(TGxRGBA
.Create(0, 255, 0));
153 result
['frame-color#disabled@box'] := TStyleValue
.Create(TGxRGBA
.Create(127, 127, 127));
154 result
['frame-text-color#disabled@box'] := TStyleValue
.Create(TGxRGBA
.Create(127, 127, 127));
155 result
['frame-icon-color#disabled@box'] := TStyleValue
.Create(TGxRGBA
.Create(127, 127, 127));
158 result
['back-color@button'] := TStyleValue
.Create(TGxRGBA
.Create(0, 96, 255));
159 result
['text-color@button'] := TStyleValue
.Create(TGxRGBA
.Create(255, 255, 255));
161 result
['back-color#inactive@button'] := TStyleValue
.Create(TGxRGBA
.Create(0, 0, 127));
162 result
['text-color#inactive@button'] := TStyleValue
.Create(TGxRGBA
.Create(196, 196, 196));
164 result
['back-color#disabled@button'] := TStyleValue
.Create(TGxRGBA
.Create(0, 0, 127));
165 result
['text-color#disabled@button'] := TStyleValue
.Create(TGxRGBA
.Create(96, 96, 96));
169 function uiFindStyle (const stname
: AnsiString): TUIStyle
;
173 if (Length(stname
) > 0) then
175 for stl
in styles
do if (strEquCI1251(stl
.mId
, stname
)) then begin result
:= stl
; exit
; end;
177 for stl
in styles
do if (strEquCI1251(stl
.mId
, 'default')) then begin result
:= stl
; exit
; end;
178 stl
:= createDefaultStyle();
179 SetLength(styles
, Length(styles
)+1);
180 styles
[High(styles
)] := stl
;
185 procedure uiLoadStyles (const fname
: AnsiString);
189 st
:= openDiskFileRO(fname
);
198 procedure uiLoadStyles (st
: TStream
);
204 if (st
= nil) then raise Exception
.Create('cannot load UI styles from nil stream');
205 par
:= TFileTextParser
.Create(st
, false, [par
.TOption
.SignedNumbers
, par
.TOption
.DollarIsId
, par
.TOption
.DashIsId
]);
208 while (not par
.isEOF
) do
210 stl
:= TUIStyle
.Create('');
212 //writeln('new style: <', stl.mId, '>');
214 while (f
< Length(styles
)) do begin if (strEquCI1251(styles
[f
].mId
, stl
.mId
)) then break
; Inc(f
); end;
215 if (f
< Length(styles
)) then
217 FreeAndNil(styles
[f
]);
222 SetLength(styles
, f
+1);
231 // we should have "default" style
232 for f
:= 0 to High(styles
) do if (strEquCI1251(styles
[f
].mId
, 'default')) then exit
;
233 stl
:= createDefaultStyle();
234 SetLength(styles
, Length(styles
)+1);
235 styles
[High(styles
)] := stl
;
239 // ////////////////////////////////////////////////////////////////////////// //
240 constructor TStyleValue
.Create (v
: Boolean; okToInherit
: Boolean=true); begin vtype
:= TType
.Bool
; allowInherit
:= okToInherit
; bval
:= v
; end;
241 constructor TStyleValue
.Create (v
: Integer; okToInherit
: Boolean=true); begin vtype
:= TType
.Int
; allowInherit
:= okToInherit
; ival
:= v
; end;
243 constructor TStyleValue
.Create (ar
, ag
, ab
: Integer; okToInherit
: Boolean=true);
245 vtype
:= TType
.Color
;
246 allowInherit
:= okToInherit
;
247 r
:= nmax(0, nmin(ar
, 255));
248 g
:= nmax(0, nmin(ag
, 255));
249 b
:= nmax(0, nmin(ab
, 255));
253 constructor TStyleValue
.Create (ar
, ag
, ab
, aa
: Integer; okToInherit
: Boolean=true);
255 vtype
:= TType
.Color
;
256 allowInherit
:= okToInherit
;
257 r
:= nmax(0, nmin(ar
, 255));
258 g
:= nmax(0, nmin(ag
, 255));
259 b
:= nmax(0, nmin(ab
, 255));
260 a
:= nmax(0, nmin(aa
, 255));
263 constructor TStyleValue
.Create (const v
: TGxRGBA
; okToInherit
: Boolean=true);
265 vtype
:= TType
.Color
;
266 allowInherit
:= okToInherit
;
273 function TStyleValue
.isEmpty (): Boolean; inline; begin result
:= (vtype
= TType
.Empty
); end;
274 function TStyleValue
.canInherit (): Boolean; inline; begin result
:= allowInherit
; end;
275 function TStyleValue
.asRGBA
: TGxRGBA
; inline; begin if (vtype
= TType
.Color
) then result
:= TGxRGBA
.Create(r
, g
, b
, a
) else result
:= TGxRGBA
.Create(0, 0, 0, 0); end;
276 function TStyleValue
.asRGBADef (const def
: TGxRGBA
): TGxRGBA
; inline; begin if (vtype
= TType
.Color
) then result
:= TGxRGBA
.Create(r
, g
, b
, a
) else result
:= def
; end;
277 function TStyleValue
.asIntDef (const def
: Integer): Integer; inline; begin if (vtype
= TType
.Int
) then result
:= ival
else if (vtype
= TType
.Bool
) then begin if (bval
) then result
:= 1 else result
:= 0; end else result
:= def
; end;
278 function TStyleValue
.asBoolDef (const def
: Boolean): Boolean; inline; begin if (vtype
= TType
.Bool
) then result
:= bval
else if (vtype
= TType
.Int
) then result
:= (ival
<> 0) else result
:= def
; end;
281 function TStyleValue
.toString (): AnsiString;
284 TType
.Empty
: result
:= '<empty>';
285 TType
.Bool
: if bval
then result
:= 'true' else result
:= 'false';
286 TType
.Int
: result
:= formatstrf('%s', [ival
]);
287 TType
.Color
: if (a
= 255) then result
:= formatstrf('rgb(%s,%s,%s)', [r
, g
, b
]) else result
:= formatstrf('rgba(%s,%s,%s)', [r
, g
, b
, a
]);
288 else result
:= '<invalid>';
293 // ////////////////////////////////////////////////////////////////////////// //
294 procedure freeSectionCB (var v
: TStyleSection
); begin FreeAndNil(v
); end;
297 function splitPath (const path
: AnsiString; out name
, hash
, ctl
: AnsiString): Boolean;
299 hashPos
, atPos
: Integer;
305 hashPos
:= pos('#', path
);
306 atPos
:= pos('@', path
);
310 // has ctl, and (possible) hash
311 if (hashPos
> 0) then
314 if (atPos
< hashPos
) then exit
; // alas
315 if (hashPos
> 1) then name
:= Copy(path
, 1, hashPos
-1);
316 Inc(hashPos
); // skip hash
317 if (hashPos
< atPos
) then hash
:= Copy(path
, hashPos
, atPos
-hashPos
);
322 if (atPos
> 1) then name
:= Copy(path
, 1, atPos
-1);
324 Inc(atPos
); // skip "at"
325 if (atPos
<= Length(path
)) then ctl
:= Copy(path
, atPos
, Length(path
)-atPos
+1);
327 else if (hashPos
> 0) then
330 if (hashPos
> 1) then name
:= Copy(path
, 1, hashPos
-1);
331 Inc(hashPos
); // skip hash
332 if (hashPos
<= Length(path
)) then hash
:= Copy(path
, hashPos
, Length(path
)-hashPos
+1);
343 // ////////////////////////////////////////////////////////////////////////// //
344 constructor TStyleSection
.Create ();
346 mVals
:= THashStrStyleVal
.Create();
347 mHashVals
:= THashStrSection
.Create();
348 mCtlVals
:= THashStrSection
.Create(freeSectionCB
);
352 destructor TStyleSection
.Destroy ();
355 FreeAndNil(mHashVals
);
356 FreeAndNil(mCtlVals
);
361 // "text-color#inactive@label"
362 function TStyleSection
.getValue (const path
: AnsiString): TStyleValue
;
364 name
, hash
, ctl
: AnsiString;
365 sect
: TStyleSection
= nil;
366 s1
: TStyleSection
= nil;
367 checkInheritance
: Boolean = false;
369 result
.vtype
:= result
.TType
.Empty
;
370 if (not splitPath(path
, name
, hash
, ctl
)) then exit
; // alas
371 //writeln('name:<', name, '>; hash:<', hash, '>; ctl:<', ctl, '>');
372 if (Length(name
) = 0) then exit
; // alas
374 if (Length(ctl
) > 0) then
377 if not mCtlVals
.get(ctl
, sect
) then
380 checkInheritance
:= true;
388 if (Length(hash
) > 0) then
390 if sect
.mHashVals
.get(hash
, s1
) then
392 if s1
.mVals
.get(name
, result
) then
394 //writeln('hash: <', hash, '>: val=', result.toString);
395 if (not result
.isEmpty
) and ((not checkInheritance
) or (result
.canInherit
)) then exit
;
398 //writeln('NO hash: <', hash, '>: val=', result.toString);
399 checkInheritance
:= true;
402 if sect
.mVals
.get(name
, result
) then
404 if (not result
.isEmpty
) and ((not checkInheritance
) or (result
.canInherit
)) then exit
;
407 result
.vtype
:= result
.TType
.Empty
;
411 procedure TStyleSection
.setValue (const path
: AnsiString; const val
: TStyleValue
);
413 name
, hash
, ctl
: AnsiString;
414 sect
: TStyleSection
= nil;
415 s1
: TStyleSection
= nil;
417 if (not splitPath(path
, name
, hash
, ctl
)) then exit
; // alas
419 if (Length(name
) = 0) then exit
; // no name -> nothing to do
421 if (Length(ctl
) > 0) then
423 if not mCtlVals
.get(ctl
, sect
) then
425 // create new section
426 sect
:= TStyleSection
.Create();
427 mCtlVals
.put(ctl
, sect
);
432 // no ctl, use default section
436 if (Length(hash
) > 0) then
438 if not sect
.mHashVals
.get(hash
, s1
) then
440 // create new section
441 s1
:= TStyleSection
.Create();
442 sect
.mHashVals
.put(hash
, s1
);
447 // no hash, use default section
450 s1
.mVals
.put(name
, val
);
454 // ////////////////////////////////////////////////////////////////////////// //
455 constructor TUIStyle
.Create (const aid
: AnsiString);
458 mMain
:= TStyleSection
.Create();
462 constructor TUIStyle
.Create (st
: TStream
); // parse from stream
467 mMain
:= TStyleSection
.Create();
468 if (st
= nil) then exit
;
469 par
:= TFileTextParser
.Create(st
, false, [par
.TOption
.SignedNumbers
, par
.TOption
.DollarIsId
, par
.TOption
.DashIsId
]);
478 constructor TUIStyle
.CreateFromFile (const fname
: AnsiString);
484 mMain
:= TStyleSection
.Create();
485 st
:= openDiskFileRO(fname
);
487 par
:= TFileTextParser
.Create(st
, false, [par
.TOption
.SignedNumbers
, par
.TOption
.DollarIsId
, par
.TOption
.DashIsId
]);
499 destructor TUIStyle
.Destroy ();
506 function TUIStyle
.getValue (const path
: AnsiString): TStyleValue
; inline;
508 result
:= mMain
[path
];
511 procedure TUIStyle
.setValue (const path
: AnsiString; const val
: TStyleValue
); inline;
513 mMain
.setValue(path
, val
);
517 procedure TUIStyle
.parse (par
: TTextParser
);
518 function getByte (): Byte;
520 if (par
.tokType
<> par
.TTInt
) then par
.expectInt();
521 if (par
.tokInt
< 0) or (par
.tokInt
> 255) then par
.error('invalid byte value');
522 result
:= Byte(par
.tokInt
);
526 procedure parseSection (sect
: TStyleSection
; ctlAllowed
: Boolean; hashAllowed
: Boolean);
529 sc
: TStyleSection
= nil;
532 par
.expectDelim('{');
533 while (not par
.isDelim('}')) do
535 while (par
.eatDelim(';')) do begin end;
537 if hashAllowed
and (par
.eatDelim('#')) then
539 s
:= par
.expectIdOrStr();
540 //writeln('hash: <', s, '>');
541 par
.eatDelim(':'); // optional
542 if not sect
.mHashVals
.get(s
, sc
) then
544 // create new section
545 sc
:= TStyleSection
.Create();
546 sect
.mHashVals
.put(s
, sc
);
548 parseSection(sc
, false, false);
552 if ctlAllowed
and (par
.eatDelim('@')) then
554 s
:= par
.expectIdOrStr();
555 //writeln('ctl: <', s, '>');
556 par
.eatDelim(':'); // optional
557 if not sect
.mCtlVals
.get(s
, sc
) then
559 // create new section
560 sc
:= TStyleSection
.Create();
561 sect
.mCtlVals
.put(s
, sc
);
563 parseSection(sc
, false, true);
567 s
:= par
.expectIdOrStr();
568 //writeln('name: <', s, '>');
569 v
.allowInherit
:= true;
570 par
.expectDelim(':');
571 if (par
.eatId('rgb')) or (par
.eatId('rgba')) then
574 par
.expectDelim('(');
575 v
.vtype
:= v
.TType
.Color
;
576 v
.r
:= getByte(); par
.eatDelim(','); // optional
577 v
.g
:= getByte(); par
.eatDelim(','); // optional
578 v
.b
:= getByte(); par
.eatDelim(','); // optional
579 if (par
.tokType
= par
.TTInt
) then
581 v
.a
:= getByte(); par
.eatDelim(','); // optional
585 v
.a
:= 255; // opaque
587 par
.expectDelim(')');
589 else if (par
.eatId('true')) or (par
.eatId('tan')) then
591 v
.vtype
:= v
.TType
.Bool
;
594 else if (par
.eatId('false')) or (par
.eatId('ona')) then
596 v
.vtype
:= v
.TType
.Bool
;
602 v
.vtype
:= v
.TType
.Int
;
603 v
.ival
:= par
.expectInt();
606 while (par
.eatDelim('!')) do
608 if (par
.eatId('no-inherit')) then v
.allowInherit
:= false
609 else par
.error('unknown flag');
611 par
.expectDelim(';');
612 sect
.mVals
.put(s
, v
);
614 par
.expectDelim('}');
619 if (not par
.isIdOrStr
) then
621 if (Length(mId
) = 0) then par
.error('style name expected');
627 if (Length(mId
) = 0) then mId
:= 'default';
629 parseSection(mMain
, true, true);