DEADSOFTWARE

fix SDL1 build
[d2df-sdl.git] / src / flexui / fui_style.pas
1 (* coded by Ketmar // Invisible Vector <ketmar@ketmar.no-ip.org>
2 * Understanding is not required. Only obedience.
3 *
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, version 3 of the License ONLY.
7 *
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
12 *
13 * You should have received a copy of the GNU General Public License
14 * along with this program. If not, see <http://www.gnu.org/licenses/>.
15 *)
16 {$INCLUDE ../shared/a_modes.inc}
17 {.$DEFINE UI_STYLE_DEBUG_SEARCH}
18 unit fui_style;
20 interface
22 uses
23 SysUtils, Classes,
24 fui_common, // for TGxRGBA
25 xstreams, xparser, utils, hashtable;
28 type
29 TStyleSection = class;
31 TStyleValue = packed record
32 public
33 type TType = (Empty, Bool, Int, Color, Str);
35 public
36 constructor Create (v: Boolean);
37 constructor Create (v: Integer);
38 constructor Create (ar, ag, ab: Integer; aa: Integer=255);
39 constructor Create (const v: TGxRGBA);
40 constructor Create (const v: AnsiString);
42 function isEmpty (): Boolean; inline;
44 function toString (): AnsiString;
45 function asRGBA: TGxRGBA; inline;
46 function asRGBADef (const def: TGxRGBA): TGxRGBA; inline;
47 function asInt (const def: Integer=0): Integer; inline;
48 function asBool (const def: Boolean=false): Boolean; inline;
49 function asStr (const def: AnsiString=''): AnsiString; inline;
51 public
52 vtype: TType;
53 case TType of
54 TType.Bool: (bval: Boolean);
55 TType.Int: (ival: Integer);
56 TType.Color: (r, g, b, a: Byte);
57 TType.Str: (sval: Pointer); // AnsiString
58 end;
60 THashStrStyleVal = specialize THashBase<AnsiString, TStyleValue, THashKeyStrAnsiCI>;
61 THashStrSection = specialize THashBase<AnsiString, TStyleSection, THashKeyStrAnsiCI>;
63 TStyleSection = class
64 private
65 mParent: TStyleSection; // for inheritance
66 mInherits: AnsiString;
67 mHashName: AnsiString; // for this section
68 mCtlName: AnsiString; // for this section
69 mVals: THashStrStyleVal;
70 mHashes: THashStrSection;
71 mCtls: THashStrSection;
73 private
74 function getTopLevel (): TStyleSection; inline;
75 // "text-color#inactive@label"
76 function getValue (const path: AnsiString): TStyleValue;
78 public
79 constructor Create ();
80 destructor Destroy (); override;
82 function get (name, hash, ctl: AnsiString): TStyleValue;
84 public
85 property value[const path: AnsiString]: TStyleValue read getValue; default;
86 property topLevel: TStyleSection read getTopLevel;
87 end;
89 TUIStyle = class
90 private
91 mId: AnsiString; // style name ('default', for example)
92 mMain: TStyleSection;
94 private
95 procedure createMain ();
97 procedure parse (par: TTextParser);
99 function getValue (const path: AnsiString): TStyleValue; inline;
101 public
102 constructor Create (const aid: AnsiString);
103 constructor Create (st: TStream); // parse from stream
104 constructor CreateFromFile (const fname: AnsiString);
105 destructor Destroy (); override;
107 function get (name, hash, ctl: AnsiString): TStyleValue;
109 public
110 property id: AnsiString read mId;
111 property value[const path: AnsiString]: TStyleValue read getValue; default;
112 end;
115 procedure uiLoadStyles (const fname: AnsiString);
116 procedure uiLoadStyles (st: TStream);
118 // will return "default" (or raise an exception if there is no "default")
119 function uiFindStyle (const stname: AnsiString): TUIStyle;
122 implementation
124 uses
125 fui_wadread;
128 var
129 styles: array of TUIStyle = nil;
133 function createDefaultStyle (): TUIStyle;
134 var
135 st: TStream;
136 begin
137 result := nil;
138 st := TStringStream.Create(defaultStyleStr);
139 st.position := 0;
140 try
141 result := TUIStyle.Create(st);
142 finally
143 FreeAndNil(st);
144 end;
145 end;
149 function uiFindStyle (const stname: AnsiString): TUIStyle;
150 var
151 stl: TUIStyle;
152 begin
153 if (Length(stname) > 0) then
154 begin
155 for stl in styles do if (strEquCI1251(stl.mId, stname)) then begin result := stl; exit; end;
156 end;
157 for stl in styles do if (strEquCI1251(stl.mId, 'default')) then begin result := stl; exit; end;
158 raise Exception.Create('FlexUI FATAL: no "default" style in stylesheet');
160 stl := createDefaultStyle();
161 SetLength(styles, Length(styles)+1);
162 styles[High(styles)] := stl;
163 result := stl;
165 end;
168 procedure uiLoadStyles (const fname: AnsiString);
169 var
170 st: TStream;
171 begin
172 st := fuiOpenFile(fname);
173 if (st = nil) then raise Exception.Create('FlexUI file '''+fname+''' not found!');
174 try
175 uiLoadStyles(st);
176 finally
177 st.Free();
178 end;
179 end;
182 procedure uiLoadStyles (st: TStream);
183 var
184 par: TTextParser;
185 stl: TUIStyle = nil;
186 f: Integer;
187 begin
188 if (st = nil) then raise Exception.Create('cannot load UI styles from nil stream');
189 par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId, par.TOption.HtmlColors]);
190 styles := nil;
191 try
192 while (not par.isEOF) do
193 begin
194 stl := TUIStyle.Create('');
195 stl.parse(par);
196 //writeln('new style: <', stl.mId, '>');
197 f := 0;
198 while (f < Length(styles)) do begin if (strEquCI1251(styles[f].mId, stl.mId)) then break; Inc(f); end;
199 if (f < Length(styles)) then
200 begin
201 FreeAndNil(styles[f]);
202 end
203 else
204 begin
205 f := Length(styles);
206 SetLength(styles, f+1);
207 end;
208 styles[f] := stl;
209 stl := nil;
210 end;
211 finally
212 stl.Free();
213 par.Free();
214 end;
215 // we should have "default" style
216 for f := 0 to High(styles) do if (strEquCI1251(styles[f].mId, 'default')) then exit;
217 raise Exception.Create('FlexUI FATAL: no "default" style in stylesheet');
219 stl := createDefaultStyle();
220 SetLength(styles, Length(styles)+1);
221 styles[High(styles)] := stl;
223 end;
226 // ////////////////////////////////////////////////////////////////////////// //
227 procedure freeValueCB (var v: TStyleValue); begin
228 if (v.vtype = v.TType.Str) then
229 begin
230 AnsiString(v.sval) := '';
231 end;
232 v.vtype := v.TType.Empty;
233 end;
235 constructor TStyleValue.Create (v: Boolean); begin vtype := TType.Bool; bval := v; end;
236 constructor TStyleValue.Create (v: Integer); begin vtype := TType.Int; ival := v; end;
237 constructor TStyleValue.Create (const v: AnsiString); begin vtype := TType.Str; sval := Pointer(v); end;
239 constructor TStyleValue.Create (ar, ag, ab: Integer; aa: Integer=255);
240 begin
241 vtype := TType.Color;
242 r := nmax(0, nmin(ar, 255));
243 g := nmax(0, nmin(ag, 255));
244 b := nmax(0, nmin(ab, 255));
245 a := nmax(0, nmin(aa, 255));
246 end;
248 constructor TStyleValue.Create (const v: TGxRGBA);
249 begin
250 vtype := TType.Color;
251 r := v.r;
252 g := v.g;
253 b := v.b;
254 a := v.a;
255 end;
257 function TStyleValue.isEmpty (): Boolean; inline; begin result := (vtype = TType.Empty); end;
258 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;
259 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;
260 function TStyleValue.asInt (const def: Integer=0): 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;
261 function TStyleValue.asBool (const def: Boolean=false): Boolean; inline; begin if (vtype = TType.Bool) then result := bval else if (vtype = TType.Int) then result := (ival <> 0) else result := def; end;
262 function TStyleValue.asStr (const def: AnsiString=''): AnsiString; inline; begin if (vtype = TType.Str) then result := AnsiString(sval) else result := def; end;
264 function TStyleValue.toString (): AnsiString;
265 begin
266 case vtype of
267 TType.Empty: result := '<empty>';
268 TType.Bool: if bval then result := 'true' else result := 'false';
269 TType.Int: result := formatstrf('%s', [ival]);
270 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]);
271 else result := '<invalid>';
272 end;
273 end;
276 // ////////////////////////////////////////////////////////////////////////// //
277 procedure freeSectionCB (var v: TStyleSection); begin FreeAndNil(v); end;
280 function splitPath (const path: AnsiString; out name, hash, ctl: AnsiString): Boolean;
281 var
282 hashPos, atPos: Integer;
283 begin
284 result := false;
285 name := '';
286 hash := '';
287 ctl := '';
288 hashPos := pos('#', path);
289 atPos := pos('@', path);
290 // split
291 if (atPos > 0) then
292 begin
293 // has ctl, and (possible) hash
294 if (hashPos > 0) then
295 begin
296 // has ctl and hash
297 if (atPos < hashPos) then
298 begin
299 // @ctl#hash
300 if (atPos > 1) then name := Copy(path, 1, atPos-1);
301 Inc(atPos); // skip "at"
302 if (atPos < hashPos) then ctl := Copy(path, atPos, hashPos-atPos);
303 Inc(hashPos); // skip hash
304 if (hashPos <= Length(path)) then hash := Copy(path, hashPos, Length(path)-hashPos+1);
305 end
306 else
307 begin
308 // #hash@ctl
309 if (hashPos > 1) then name := Copy(path, 1, hashPos-1);
310 Inc(hashPos); // skip hash
311 if (hashPos < atPos) then hash := Copy(path, hashPos, atPos-hashPos);
312 Inc(atPos); // skip "at"
313 if (atPos <= Length(path)) then ctl := Copy(path, atPos, Length(path)-atPos+1);
314 end;
315 end
316 else
317 begin
318 // has only ctl
319 if (atPos > 1) then name := Copy(path, 1, atPos-1);
320 Inc(atPos); // skip "at"
321 if (atPos <= Length(path)) then ctl := Copy(path, atPos, Length(path)-atPos+1);
322 end;
323 end
324 else if (hashPos > 0) then
325 begin
326 // has hash
327 if (hashPos > 1) then name := Copy(path, 1, hashPos-1);
328 Inc(hashPos); // skip hash
329 if (hashPos <= Length(path)) then hash := Copy(path, hashPos, Length(path)-hashPos+1);
330 end
331 else
332 begin
333 // only name
334 name := path;
335 end;
336 result := true;
337 end;
340 // ////////////////////////////////////////////////////////////////////////// //
341 constructor TStyleSection.Create ();
342 begin
343 mParent := nil;
344 mInherits := '';
345 mHashName := '';
346 mCtlName := '';
347 mVals := THashStrStyleVal.Create(freeValueCB);
348 mHashes := THashStrSection.Create(freeSectionCB);
349 mCtls := THashStrSection.Create(freeSectionCB);
350 end;
353 destructor TStyleSection.Destroy ();
354 begin
355 FreeAndNil(mVals);
356 FreeAndNil(mHashes);
357 FreeAndNil(mCtls);
358 mParent := nil;
359 mInherits := '';
360 mHashName := '';
361 mCtlName := '';
362 inherited;
363 end;
366 function TStyleSection.getTopLevel (): TStyleSection; inline;
367 begin
368 result := self;
369 while (result.mParent <> nil) do result := result.mParent;
370 end;
373 function TStyleSection.get (name, hash, ctl: AnsiString): TStyleValue;
374 var
375 tmp: AnsiString;
376 sect, s1, so: TStyleSection;
377 jumpsLeft: Integer = 32; // max inheritance level
378 skipInherits: Boolean = false;
379 begin
380 result.vtype := result.TType.Empty;
381 if (Length(name) = 0) then exit; // alas
382 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('***GET: <', name, '#', hash, '@', ctl, '>');{$ENDIF}
383 // try control
384 sect := self;
385 if (Length(ctl) > 0) then
386 begin
387 if (not strEquCI1251(ctl, mCtlName)) then
388 begin
389 // has ctl section?
390 if (not topLevel.mCtls.get(ctl, sect)) then sect := topLevel;
391 end;
392 end;
393 // has hash?
394 if (Length(hash) > 0) then
395 begin
396 if (not strEquCI1251(hash, sect.mHashName)) then
397 begin
398 if (sect.mHashes.get(hash, s1)) then sect := s1;
399 end;
400 end;
401 // try name, go up with inheritance
402 while (jumpsLeft > 0) do
403 begin
404 if (sect.mVals.get(name, result)) then
405 begin
406 if (not result.isEmpty) then exit; // i found her!
407 end;
408 // go up
409 if (skipInherits) or (Length(sect.mInherits) = 0) then
410 begin
411 skipInherits := false;
412 // for hash section: try parent section first
413 if (Length(sect.mHashName) > 0) then
414 begin
415 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('search for <#', hash, '@', ctl, '> at <#', sect.mHashName, '@', sect.mCtlName, '>: hash up');{$ENDIF}
416 sect := sect.mParent;
417 if (sect = nil) then break; // alas
418 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' hash up: trying <#', sect.mHashName, '@', sect.mCtlName, '>');{$ENDIF}
419 if (sect.mVals.get(name, result)) then
420 begin
421 if (not result.isEmpty) then exit; // i found her!
422 end;
423 // move another parent up
424 sect := sect.mParent;
425 if (sect = nil) then break; // alas
426 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' hash up: jumped up twice to <#', sect.mHashName, '@', sect.mCtlName, '>');{$ENDIF}
427 end
428 else
429 begin
430 // one parent up
431 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('search for <#', hash, '@', ctl, '> at <#', sect.mHashName, '@', sect.mCtlName, '>: jump up');{$ENDIF}
432 sect := sect.mParent;
433 if (sect = nil) then break; // alas
434 end;
435 // here, we should have non-hash section
436 assert(Length(sect.mHashName) = 0);
437 // if we want hash, try to find it, otherwise do nothing
438 if (Length(hash) > 0) then
439 begin
440 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' search for <#', hash, '@', ctl, '> at <#', sect.mHashName, '@', sect.mCtlName, '>: hash down');{$ENDIF}
441 if (sect.mHashes.get(hash, s1)) then
442 begin
443 sect := s1;
444 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' found <#', sect.mHashName, '@', sect.mCtlName, '>');{$ENDIF}
445 end;
446 end;
447 end
448 else
449 begin
450 // inheritance
451 Dec(jumpsLeft);
452 if (jumpsLeft < 1) then break; // alas
453 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('inherits: <', sect.mInherits, '>');{$ENDIF}
454 // parse inherit string
455 if (not splitPath(sect.mInherits, tmp, hash, ctl)) then exit; // alas
456 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('inherits: <', hash, '>:<', ctl, '>');{$ENDIF}
457 // find section
458 if (Length(ctl) > 0) then
459 begin
460 // ctl
461 if (strEquCI1251(ctl, '$main$')) then sect := topLevel
462 else if (strEquCI1251(ctl, '$up$')) then begin if (Length(sect.mHashName) <> 0) then sect := sect.mParent.mParent else sect := sect.mParent; end
463 else if (not topLevel.mCtls.get(ctl, sect)) then sect := topLevel;
464 if (sect = nil) then break; // alas
465 if (Length(hash) > 0) then
466 begin
467 if (sect.mHashes.get(hash, s1)) then sect := s1;
468 end;
469 end
470 else
471 begin
472 // hash
473 assert(Length(hash) > 0);
474 // dummy loop, so i can use `break`
475 repeat
476 // get out of hash section
477 if (Length(sect.mHashName) > 0) then
478 begin
479 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln('hash-jump-up: <#', sect.mHashName, '@', sect.mCtlName, '>');{$ENDIF}
480 sect := sect.mParent;
481 if (sect = nil) then break; // alas
482 // check for hash section in parent; use parent if there is no such hash section
483 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' checking parent: <#', sect.mHashName, '@', sect.mCtlName, '> for <#', hash, '>');{$ENDIF}
484 so := sect;
485 if (sect.mHashes.get(hash, s1)) then
486 begin
487 if (s1 <> sect) and (s1 <> so) then
488 begin
489 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' found in parent: <#', sect.mHashName, '@', sect.mCtlName, '> for <#', hash, '>');{$ENDIF}
490 sect := s1;
491 end;
492 end;
493 end
494 else
495 begin
496 // we're in parent, try to find hash section
497 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' checking: <#', sect.mHashName, '@', sect.mCtlName, '> for <#', hash, '>');{$ENDIF}
498 if (sect.mHashes.get(hash, s1)) then
499 begin
500 {$IFDEF UI_STYLE_DEBUG_SEARCH}writeln(' found: <#', sect.mHashName, '@', sect.mCtlName, '> for <#', hash, '>');{$ENDIF}
501 sect := s1;
502 end
503 else
504 begin
505 // reuse current parent, but don't follow inheritance for it
506 skipInherits := true;
507 end;
508 end;
509 until true;
510 if (sect = nil) then break;
511 end;
512 end;
513 end;
514 // alas
515 result.vtype := result.TType.Empty;
516 end;
519 // "text-color#inactive@label"
520 function TStyleSection.getValue (const path: AnsiString): TStyleValue;
521 var
522 name, hash, ctl: AnsiString;
523 begin
524 result.vtype := result.TType.Empty;
525 if (not splitPath(path, name, hash, ctl)) then exit; // alas
526 //writeln('name:<', name, '>; hash:<', hash, '>; ctl:<', ctl, '>');
527 result := get(name, hash, ctl);
528 end;
531 // ////////////////////////////////////////////////////////////////////////// //
532 constructor TUIStyle.Create (const aid: AnsiString);
533 begin
534 mId := aid;
535 createMain();
536 end;
539 constructor TUIStyle.Create (st: TStream); // parse from stream
540 var
541 par: TTextParser;
542 begin
543 mId := '';
544 createMain();
545 if (st = nil) then exit;
546 par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId, par.TOption.HtmlColors]);
547 try
548 parse(par);
549 finally
550 par.Free();
551 end;
552 end;
555 constructor TUIStyle.CreateFromFile (const fname: AnsiString);
556 var
557 st: TStream;
558 begin
559 st := openDiskFileRO(fname);
560 try
561 Create(st);
562 finally
563 st.Free();
564 end;
565 end;
568 destructor TUIStyle.Destroy ();
569 begin
570 mId := '';
571 FreeAndNil(mMain);
572 end;
575 procedure TUIStyle.createMain ();
576 begin
577 mMain := TStyleSection.Create();
578 mMain.mCtlName := '$main$';
579 end;
582 function TUIStyle.getValue (const path: AnsiString): TStyleValue; inline;
583 begin
584 result := mMain[path];
585 end;
587 function TUIStyle.get (name, hash, ctl: AnsiString): TStyleValue;
588 begin
589 result := mMain.get(name, hash, ctl);
590 end;
593 procedure TUIStyle.parse (par: TTextParser);
594 function getByte (): Byte;
595 begin
596 if (par.tokType <> par.TTInt) then par.expectInt();
597 if (par.tokInt < 0) or (par.tokInt > 255) then par.error('invalid byte value');
598 result := Byte(par.tokInt);
599 par.skipToken();
600 end;
602 procedure parseSection (sect: TStyleSection; ctlAllowed: Boolean; hashAllowed: Boolean);
603 var
604 s, inh: AnsiString;
605 sc: TStyleSection = nil;
606 v: TStyleValue;
608 procedure parseInherit ();
609 begin
610 inh := '';
611 if (par.eatDelim('(')) then
612 begin
613 if (par.eatDelim(')')) then par.error('empty inheritance is not allowed');
614 if (par.eatDelim('#')) then
615 begin
616 inh := '#';
617 inh += par.expectId();
618 end;
619 if (par.eatDelim('@')) then
620 begin
621 inh += '#';
622 inh += par.expectId();
623 end;
624 par.expectDelim(')');
625 end;
626 end;
628 function nib2c (n: Integer): Byte; inline;
629 begin
630 if (n < 0) then result := 0
631 else if (n > 15) then result := 255
632 else result := Byte(255*n div 15);
633 end;
635 begin
636 s := '';
637 inh := '';
638 par.expectDelim('{');
639 while (not par.isDelim('}')) do
640 begin
641 while (par.eatDelim(';')) do begin end;
642 // ctl
643 if ctlAllowed and (par.eatDelim('@')) then
644 begin
645 s := par.expectId();
646 parseInherit();
647 par.eatDelim(':'); // optional
648 if (not sect.mCtls.get(s, sc)) then
649 begin
650 // create new section
651 sc := TStyleSection.Create();
652 sc.mParent := sect;
653 sc.mInherits := inh;
654 sc.mHashName := '';
655 sc.mCtlName := s;
656 sect.mCtls.put(s, sc);
657 end
658 else
659 begin
660 assert(sc.mParent = sect);
661 assert(sc.mHashName = '');
662 assert(sc.mCtlName = s);
663 if (Length(sc.mInherits) <> 0) and (Length(inh) <> 0) then par.error('double inheritance');
664 sc.mInherits := inh;
665 end;
666 if (not par.eatDelim(';')) then parseSection(sc, false, true);
667 continue;
668 end;
669 // hash
670 if hashAllowed and (par.eatDelim('#')) then
671 begin
672 s := par.expectId();
673 parseInherit();
674 par.eatDelim(':'); // optional
675 if (not sect.mHashes.get(s, sc)) then
676 begin
677 // create new section
678 sc := TStyleSection.Create();
679 sc.mParent := sect;
680 sc.mInherits := inh;
681 sc.mHashName := s;
682 sc.mCtlName := '';
683 sect.mHashes.put(s, sc);
684 end
685 else
686 begin
687 assert(sc.mParent = sect);
688 assert(sc.mHashName = s);
689 assert(sc.mCtlName = '');
690 if (Length(sc.mInherits) <> 0) and (Length(inh) <> 0) then par.error('double inheritance');
691 sc.mInherits := inh;
692 end;
693 if (not par.eatDelim(';')) then parseSection(sc, false, false);
694 continue;
695 end;
696 // name
697 s := par.expectId();
698 par.expectDelim(':');
699 if (par.eatId('rgb')) or (par.eatId('rgba')) then
700 begin
701 // color
702 par.expectDelim('(');
703 v.vtype := v.TType.Color;
704 v.r := getByte(); par.eatDelim(','); // optional
705 v.g := getByte(); par.eatDelim(','); // optional
706 v.b := getByte(); par.eatDelim(','); // optional
707 if (par.tokType = par.TTInt) then
708 begin
709 v.a := getByte(); par.eatDelim(','); // optional
710 end
711 else
712 begin
713 v.a := 255; // opaque
714 end;
715 par.expectDelim(')');
716 end
717 else if (par.isId) and (par.tokStr[1] = '#') then
718 begin
719 // html color
720 assert((Length(par.tokStr) = 4) or (Length(par.tokStr) = 7));
721 //writeln('<', par.tokStr, '>; {', par.curChar, '}');
722 v.vtype := v.TType.Color;
723 if (Length(par.tokStr) = 4) then
724 begin
725 // #rgb
726 v.r := nib2c(digitInBase(par.tokStr[2], 16));
727 v.g := nib2c(digitInBase(par.tokStr[3], 16));
728 v.b := nib2c(digitInBase(par.tokStr[4], 16));
729 end
730 else
731 begin
732 // #rrggbb
733 v.r := Byte(digitInBase(par.tokStr[2], 16)*16+digitInBase(par.tokStr[3], 16));
734 v.g := Byte(digitInBase(par.tokStr[4], 16)*16+digitInBase(par.tokStr[5], 16));
735 v.b := Byte(digitInBase(par.tokStr[6], 16)*16+digitInBase(par.tokStr[7], 16));
736 end;
737 v.a := 255;
738 //writeln(' r=', v.r, '; g=', v.g, '; b=', v.b);
739 par.skipToken();
740 end
741 else if (par.eatId('true')) or (par.eatId('tan')) then
742 begin
743 v.vtype := v.TType.Bool;
744 v.bval := true;
745 end
746 else if (par.eatId('false')) or (par.eatId('ona')) then
747 begin
748 v.vtype := v.TType.Bool;
749 v.bval := false;
750 end
751 else if (par.isStr) then
752 begin
753 // string value
754 v := TStyleValue.Create(par.tokStr);
755 par.skipToken();
756 end
757 else if (par.eatId('inherit')) then
758 begin
759 v.vtype := v.TType.Empty;
760 end
761 else
762 begin
763 // should be int
764 v.vtype := v.TType.Int;
765 v.ival := par.expectInt();
766 end;
767 par.expectDelim(';');
768 sect.mVals.put(s, v);
769 end;
770 par.expectDelim('}');
771 end;
773 begin
774 // style name
775 if (not par.isIdOrStr) then
776 begin
777 if (Length(mId) = 0) then par.error('style name expected');
778 end
779 else
780 begin
781 mId := par.tokStr;
782 end;
783 if (Length(mId) = 0) then mId := 'default';
784 par.skipToken();
785 if (not par.eatDelim(';')) then parseSection(mMain, true, true);
786 end;
789 end.