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;
  19
  20 interface
  21
  22 uses
  23   SysUtils, Classes,
  24   fui_common, // for TGxRGBA
  25   xstreams, xparser, utils, hashtable;
  26
  27
  28 type
  29   TStyleSection = class;
  30
  31   TStyleValue = packed record
  32   public
  33     type TType = (Empty, Bool, Int, Color, Str);
  34
  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);
  41
  42     function isEmpty (): Boolean; inline;
  43
  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;
  50
  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;
  59
  60   THashStrStyleVal = specialize THashBase<AnsiString, TStyleValue, THashKeyStrAnsiCI>;
  61   THashStrSection = specialize THashBase<AnsiString, TStyleSection, THashKeyStrAnsiCI>;
  62
  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;
  72
  73   private
  74     function getTopLevel (): TStyleSection; inline;
  75     // "text-color#inactive@label"
  76     function getValue (const path: AnsiString): TStyleValue;
  77
  78   public
  79     constructor Create ();
  80     destructor Destroy (); override;
  81
  82     function get (name, hash, ctl: AnsiString): TStyleValue;
  83
  84   public
  85     property value[const path: AnsiString]: TStyleValue read getValue; default;
  86     property topLevel: TStyleSection read getTopLevel;
  87   end;
  88
  89   TUIStyle = class
  90   private
  91     mId: AnsiString; // style name ('default', for example)
  92     mMain: TStyleSection;
  93
  94   private
  95     procedure createMain ();
  96
  97     procedure parse (par: TTextParser);
  98
  99     function getValue (const path: AnsiString): TStyleValue; inline;
 100
 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;
 106
 107     function get (name, hash, ctl: AnsiString): TStyleValue;
 108
 109   public
 110     property id: AnsiString read mId;
 111     property value[const path: AnsiString]: TStyleValue read getValue; default;
 112   end;
 113
 114
 115 procedure uiLoadStyles (const fname: AnsiString);
 116 procedure uiLoadStyles (st: TStream);
 117
 118 // will return "default" (or raise an exception if there is no "default")
 119 function uiFindStyle (const stname: AnsiString): TUIStyle;
 120
 121
 122 implementation
 123
 124 uses
 125   fui_wadread;
 126
 127
 128 var
 129   styles: array of TUIStyle = nil;
 130
 131
 132 {
 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;
 146 }
 147
 148
 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');
 159   {
 160   stl := createDefaultStyle();
 161   SetLength(styles, Length(styles)+1);
 162   styles[High(styles)] := stl;
 163   result := stl;
 164   }
 165 end;
 166
 167
 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;
 180
 181
 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');
 218   {
 219   stl := createDefaultStyle();
 220   SetLength(styles, Length(styles)+1);
 221   styles[High(styles)] := stl;
 222   }
 223 end;
 224
 225
 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;
 234
 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;
 238
 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;
 247
 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;
 256
 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;
 263
 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;
 274
 275
 276 // ////////////////////////////////////////////////////////////////////////// //
 277 procedure freeSectionCB (var v: TStyleSection); begin FreeAndNil(v); end;
 278
 279
 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;
 338
 339
 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;
 351
 352
 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;
 364
 365
 366 function TStyleSection.getTopLevel (): TStyleSection; inline;
 367 begin
 368   result := self;
 369   while (result.mParent <> nil) do result := result.mParent;
 370 end;
 371
 372
 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;
 517
 518
 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;
 529
 530
 531 // ////////////////////////////////////////////////////////////////////////// //
 532 constructor TUIStyle.Create (const aid: AnsiString);
 533 begin
 534   mId := aid;
 535   createMain();
 536 end;
 537
 538
 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;
 553
 554
 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;
 566
 567
 568 destructor TUIStyle.Destroy ();
 569 begin
 570   mId := '';
 571   FreeAndNil(mMain);
 572 end;
 573
 574
 575 procedure TUIStyle.createMain ();
 576 begin
 577   mMain := TStyleSection.Create();
 578   mMain.mCtlName := '$main$';
 579 end;
 580
 581
 582 function TUIStyle.getValue (const path: AnsiString): TStyleValue; inline;
 583 begin
 584   result := mMain[path];
 585 end;
 586
 587 function TUIStyle.get (name, hash, ctl: AnsiString): TStyleValue;
 588 begin
 589   result := mMain.get(name, hash, ctl);
 590 end;
 591
 592
 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;
 601
 602   procedure parseSection (sect: TStyleSection; ctlAllowed: Boolean; hashAllowed: Boolean);
 603   var
 604     s, inh: AnsiString;
 605     sc: TStyleSection = nil;
 606     v: TStyleValue;
 607
 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;
 627
 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;
 634
 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;
 772
 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;
 787
 788
 789 end.