From e4b651a876eccee3cdc7f96cef3203db81db369b Mon Sep 17 00:00:00 2001 From: Ketmar Dark Date: Thu, 28 Sep 2017 21:52:34 +0300 Subject: [PATCH] FlexUI: simple styling system (yay, no more hardcoded colors!) --- src/game/Doom2DF.dpr | 1 + src/gx/gh_ui.pas | 221 +++++++++++--- src/gx/gh_ui_style.pas | 615 +++++++++++++++++++++++++++++++++++++++ src/shared/hashtable.pas | 123 +++++++- src/shared/utils.pas | 44 +-- src/shared/xdynrec.pas | 4 +- src/shared/xparser.pas | 129 ++++---- 7 files changed, 1000 insertions(+), 137 deletions(-) create mode 100644 src/gx/gh_ui_style.pas diff --git a/src/game/Doom2DF.dpr b/src/game/Doom2DF.dpr index e81b4ae..41c7aac 100644 --- a/src/game/Doom2DF.dpr +++ b/src/game/Doom2DF.dpr @@ -114,6 +114,7 @@ uses sdlcarcass in '../gx/sdlcarcass.pas', glgfx in '../gx/glgfx.pas', gh_ui_common in '../gx/gh_ui_common.pas', + gh_ui_style in '../gx/gh_ui_style.pas', gh_ui in '../gx/gh_ui.pas', gh_flexlay in '../gx/gh_flexlay.pas'; diff --git a/src/gx/gh_ui.pas b/src/gx/gh_ui.pas index c33a93f..be597b0 100644 --- a/src/gx/gh_ui.pas +++ b/src/gx/gh_ui.pas @@ -24,6 +24,7 @@ uses SysUtils, Classes, GL, GLExt, SDL2, gh_ui_common, + gh_ui_style, sdlcarcass, glgfx, xparser; @@ -36,9 +37,16 @@ type public type TActionCB = procedure (me: TUIControl; uinfo: Integer); + public + const ClrIdxActive = 0; + const ClrIdxDisabled = 1; + const ClrIdxInactive = 2; + const ClrIdxMax = 2; + private mParent: TUIControl; mId: AnsiString; + mStyleId: AnsiString; mX, mY: Integer; mWidth, mHeight: Integer; mFrameWidth, mFrameHeight: Integer; @@ -50,11 +58,24 @@ type mEscClose: Boolean; // valid only for top-level controls mEatKeys: Boolean; mDrawShadow: Boolean; + // colors + mCtl4Style: AnsiString; + mBackColor: array[0..ClrIdxMax] of TGxRGBA; + mTextColor: array[0..ClrIdxMax] of TGxRGBA; + mFrameColor: array[0..ClrIdxMax] of TGxRGBA; + mFrameTextColor: array[0..ClrIdxMax] of TGxRGBA; + mFrameIconColor: array[0..ClrIdxMax] of TGxRGBA; + mDarken: array[0..ClrIdxMax] of Integer; // -1: none private scis: TScissorSave; scallowed: Boolean; + protected + procedure updateStyle (); virtual; + procedure cacheStyle (root: TUIStyle); virtual; + function getColorIndex (): Integer; inline; + protected function getEnabled (): Boolean; procedure setEnabled (v: Boolean); inline; @@ -197,6 +218,7 @@ type public property id: AnsiString read mId; + property styleId: AnsiString read mStyleId; property x0: Integer read mX; property y0: Integer read mY; property height: Integer read mHeight; @@ -219,6 +241,9 @@ type mFreeOnClose: Boolean; // default: false mDoCenter: Boolean; // after layouting + protected + procedure cacheStyle (root: TUIStyle); override; + protected procedure activated (); override; procedure blurred (); override; @@ -229,6 +254,8 @@ type public constructor Create (const atitle: AnsiString; ax, ay: Integer; aw: Integer=-1; ah: Integer=-1); + procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser + function parseProperty (const prname: AnsiString; par: TTextParser): Boolean; override; procedure centerInScreen (); @@ -304,6 +331,8 @@ type public constructor Create (ahoriz: Boolean); + procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser + function parseProperty (const prname: AnsiString; par: TTextParser): Boolean; override; procedure drawControl (gx, gy: Integer); override; @@ -335,6 +364,8 @@ type // ////////////////////////////////////////////////////////////////////// // TUILine = class(TUIControl) public + procedure AfterConstruction (); override; // so it will be correctly initialized when created from parser + function parseProperty (const prname: AnsiString; par: TTextParser): Boolean; override; procedure drawControl (gx, gy: Integer); override; @@ -382,6 +413,8 @@ procedure uiAddWindow (ctl: TUIControl); procedure uiRemoveWindow (ctl: TUIControl); // will free window if `mFreeOnClose` is `true` function uiVisibleWindow (ctl: TUIControl): Boolean; +procedure uiUpdateStyles (); + // ////////////////////////////////////////////////////////////////////////// // // do layouting @@ -482,6 +515,14 @@ var uiTopList: array of TUIControl = nil; +procedure uiUpdateStyles (); +var + ctl: TUIControl; +begin + for ctl in uiTopList do ctl.updateStyle(); +end; + + function uiMouseEvent (ev: THMouseEvent): Boolean; var f, c: Integer; @@ -528,7 +569,7 @@ end; procedure uiDraw (); var - f: Integer; + f, cidx: Integer; ctl: TUIControl; begin glMatrixMode(GL_MODELVIEW); @@ -540,7 +581,9 @@ begin begin ctl := uiTopList[f]; ctl.draw(); - if (f <> High(uiTopList)) then darkenRect(ctl.x0, ctl.y0, ctl.width, ctl.height, 128); + cidx := ctl.getColorIndex; + //if (f <> High(uiTopList)) then darkenRect(ctl.x0, ctl.y0, ctl.width, ctl.height, 128); + if (ctl.mDarken[cidx] > 0) then darkenRect(ctl.x0, ctl.y0, ctl.width, ctl.height, ctl.mDarken[cidx]); end; finally glMatrixMode(GL_MODELVIEW); @@ -573,6 +616,7 @@ begin if (Length(uiTopList) > 0) then uiTopList[High(uiTopList)].blurred(); SetLength(uiTopList, Length(uiTopList)+1); uiTopList[High(uiTopList)] := ctl; + ctl.updateStyle(); ctl.activated(); end; @@ -624,6 +668,7 @@ end; constructor TUIControl.Create (); begin mParent := nil; + mId := ''; mX := 0; mY := 0; mWidth := 64; @@ -650,6 +695,8 @@ begin mLineStart := false; mHGroup := ''; mVGroup := ''; + mStyleId := ''; + mCtl4Style := ''; mAlign := -1; // left/top mExpand := false; end; @@ -690,6 +737,63 @@ begin end; +function TUIControl.getColorIndex (): Integer; inline; +begin + if (not mEnabled) then begin result := ClrIdxDisabled; exit; end; + if (getFocused) then begin result := ClrIdxActive; exit; end; + result := ClrIdxInactive; +end; + +procedure TUIControl.updateStyle (); +var + stl: TUIStyle = nil; + ctl: TUIControl; +begin + ctl := self; + while (ctl <> nil) do + begin + if (Length(ctl.mStyleId) <> 0) then begin stl := uiFindStyle(ctl.mStyleId); break; end; + ctl := ctl.mParent; + end; + if (stl = nil) then stl := uiFindStyle(''); // default + cacheStyle(stl); + for ctl in mChildren do ctl.updateStyle(); +end; + +procedure TUIControl.cacheStyle (root: TUIStyle); +var + cst: AnsiString = ''; +begin + //writeln('caching style for <', className, '> (', mCtl4Style, ')...'); + if (Length(mCtl4Style) > 0) then + begin + cst := mCtl4Style; + if (cst[1] <> '@') then cst := '@'+cst; + end; + // active + mBackColor[ClrIdxActive] := root['back-color'+cst].asRGBADef(TGxRGBA.Create(0, 0, 128)); + mTextColor[ClrIdxActive] := root['text-color'+cst].asRGBADef(TGxRGBA.Create(255, 255, 255)); + mFrameColor[ClrIdxActive] := root['frame-color'+cst].asRGBADef(TGxRGBA.Create(255, 255, 255)); + mFrameTextColor[ClrIdxActive] := root['frame-text-color'+cst].asRGBADef(TGxRGBA.Create(255, 255, 255)); + mFrameIconColor[ClrIdxActive] := root['frame-icon-color'+cst].asRGBADef(TGxRGBA.Create(0, 255, 0)); + mDarken[ClrIdxActive] := root['darken'+cst].asIntDef(-1); + // disabled + mBackColor[ClrIdxDisabled] := root['back-color#disabled'+cst].asRGBADef(TGxRGBA.Create(0, 0, 128)); + mTextColor[ClrIdxDisabled] := root['text-color#disabled'+cst].asRGBADef(TGxRGBA.Create(127, 127, 127)); + mFrameColor[ClrIdxDisabled] := root['frame-color#disabled'+cst].asRGBADef(TGxRGBA.Create(127, 127, 127)); + mFrameTextColor[ClrIdxDisabled] := root['frame-text-color#disabled'+cst].asRGBADef(TGxRGBA.Create(127, 127, 127)); + mFrameIconColor[ClrIdxDisabled] := root['frame-icon-color#disabled'+cst].asRGBADef(TGxRGBA.Create(0, 127, 0)); + mDarken[ClrIdxDisabled] := root['darken#disabled'+cst].asIntDef(128); + // inactive + mBackColor[ClrIdxInactive] := root['back-color#inactive'+cst].asRGBADef(TGxRGBA.Create(0, 0, 128)); + mTextColor[ClrIdxInactive] := root['text-color#inactive'+cst].asRGBADef(TGxRGBA.Create(255, 255, 255)); + mFrameColor[ClrIdxInactive] := root['frame-color#inactive'+cst].asRGBADef(TGxRGBA.Create(255, 255, 255)); + mFrameTextColor[ClrIdxInactive] := root['frame-text-color#inactive'+cst].asRGBADef(TGxRGBA.Create(255, 255, 255)); + mFrameIconColor[ClrIdxInactive] := root['frame-icon-color#inactive'+cst].asRGBADef(TGxRGBA.Create(0, 255, 0)); + mDarken[ClrIdxInactive] := root['darken#inactive'+cst].asIntDef(128); +end; + + // ////////////////////////////////////////////////////////////////////////// // function TUIControl.getDefSize (): TLaySize; inline; begin result := mLayDefSize; end; function TUIControl.getMaxSize (): TLaySize; inline; begin result := mLayMaxSize; end; @@ -926,7 +1030,8 @@ end; function TUIControl.parseProperty (const prname: AnsiString; par: TTextParser): Boolean; begin result := true; - if (strEquCI1251(prname, 'id')) then begin mId := par.expectStrOrId(true); exit; end; // allow empty strings + if (strEquCI1251(prname, 'id')) then begin mId := par.expectIdOrStr(true); exit; end; // allow empty strings + if (strEquCI1251(prname, 'style')) then begin mStyleId := par.expectIdOrStr(); exit; end; // no empty strings if (strEquCI1251(prname, 'flex')) then begin flex := par.expectInt(); exit; end; // sizes if (strEquCI1251(prname, 'defsize')) or (strEquCI1251(prname, 'size')) then begin mDefSize := parseSize(par); exit; end; @@ -941,8 +1046,8 @@ begin if (strEquCI1251(prname, 'expand')) then begin mExpand := parseBool(par); exit; end; // align if (strEquCI1251(prname, 'align')) then begin mAlign := parseAnyAlign(par); exit; end; - if (strEquCI1251(prname, 'hgroup')) then begin mHGroup := par.expectStrOrId(true); exit; end; // allow empty strings - if (strEquCI1251(prname, 'vgroup')) then begin mVGroup := par.expectStrOrId(true); exit; end; // allow empty strings + if (strEquCI1251(prname, 'hgroup')) then begin mHGroup := par.expectIdOrStr(true); exit; end; // allow empty strings + if (strEquCI1251(prname, 'vgroup')) then begin mVGroup := par.expectIdOrStr(true); exit; end; // allow empty strings // other if (strEquCI1251(prname, 'canfocus')) then begin mCanFocus := parseBool(par); exit; end; if (strEquCI1251(prname, 'enabled')) then begin mEnabled := parseBool(par); exit; end; @@ -998,7 +1103,15 @@ end; function TUIControl.getFocused (): Boolean; inline; begin - if (mParent = nil) then result := (Length(uiTopList) > 0) and (uiTopList[High(uiTopList)] = self) else result := (topLevel.mFocused = self); + if (mParent = nil) then + begin + result := (Length(uiTopList) > 0) and (uiTopList[High(uiTopList)] = self); + end + else + begin + result := (topLevel.mFocused = self); + if (result) then result := (Length(uiTopList) > 0) and (uiTopList[High(uiTopList)] = topLevel); + end; end; @@ -1305,7 +1418,7 @@ end; procedure TUIControl.drawControl (gx, gy: Integer); begin - if (mParent = nil) then darkenRect(gx, gy, mWidth, mHeight, 64); + //if (mParent = nil) then darkenRect(gx, gy, mWidth, mHeight, 64); end; procedure TUIControl.drawControlPost (gx, gy: Integer); @@ -1399,6 +1512,11 @@ begin mFrameWidth := 8; mFrameHeight := 8; mTitle := atitle; +end; + +procedure TUITopWindow.AfterConstruction (); +begin + inherited AfterConstruction(); if (mWidth < mFrameWidth*2+3*8) then mWidth := mFrameWidth*2+3*8; if (mHeight < mFrameHeight*2) then mHeight := mFrameHeight*2; if (Length(mTitle) > 0) then @@ -1410,6 +1528,7 @@ begin mWaitingClose := false; mInClose := false; closeCB := nil; + mCtl4Style := ''; end; @@ -1417,7 +1536,7 @@ function TUITopWindow.parseProperty (const prname: AnsiString; par: TTextParser) begin if (strEquCI1251(prname, 'title')) or (strEquCI1251(prname, 'caption')) then begin - mTitle := par.expectStrOrId(true); + mTitle := par.expectIdOrStr(true); result := true; exit; end; @@ -1440,6 +1559,12 @@ begin end; +procedure TUITopWindow.cacheStyle (root: TUIStyle); +begin + inherited cacheStyle(root); +end; + + procedure TUITopWindow.centerInScreen (); begin if (mWidth > 0) and (mHeight > 0) then @@ -1452,37 +1577,36 @@ end; procedure TUITopWindow.drawControl (gx, gy: Integer); begin - fillRect(gx, gy, mWidth, mHeight, TGxRGBA.Create(0, 0, 128)); + fillRect(gx, gy, mWidth, mHeight, mBackColor[getColorIndex]); end; procedure TUITopWindow.drawControlPost (gx, gy: Integer); -const r = 255; -const g = 255; -const b = 255; var + cidx: Integer; tx: Integer; begin + cidx := getColorIndex; if mDragging then begin - drawRectUI(mX+4, mY+4, mWidth-8, mHeight-8, TGxRGBA.Create(r, g, b)); + drawRectUI(mX+4, mY+4, mWidth-8, mHeight-8, mFrameColor[cidx]); end else begin - drawRectUI(mX+3, mY+3, mWidth-6, mHeight-6, TGxRGBA.Create(r, g, b)); - drawRectUI(mX+5, mY+5, mWidth-10, mHeight-10, TGxRGBA.Create(r, g, b)); + drawRectUI(mX+3, mY+3, mWidth-6, mHeight-6, mFrameColor[cidx]); + drawRectUI(mX+5, mY+5, mWidth-10, mHeight-10, mFrameColor[cidx]); setScissor(mFrameWidth, 0, 3*8, 8); - fillRect(mX+mFrameWidth, mY, 3*8, 8, TGxRGBA.Create(0, 0, 128)); - drawText8(mX+mFrameWidth, mY, '[ ]', TGxRGBA.Create(r, g, b)); - if mInClose then drawText8(mX+mFrameWidth+7, mY, '#', TGxRGBA.Create(0, 255, 0)) - else drawText8(mX+mFrameWidth+7, mY, '*', TGxRGBA.Create(0, 255, 0)); + fillRect(mX+mFrameWidth, mY, 3*8, 8, mBackColor[cidx]); + drawText8(mX+mFrameWidth, mY, '[ ]', mFrameColor[cidx]); + if mInClose then drawText8(mX+mFrameWidth+7, mY, '#', mFrameIconColor[cidx]) + else drawText8(mX+mFrameWidth+7, mY, '*', mFrameIconColor[cidx]); end; if (Length(mTitle) > 0) then begin setScissor(mFrameWidth+3*8, 0, mWidth-mFrameWidth*2-3*8, 8); tx := (mX+3*8)+((mWidth-3*8)-Length(mTitle)*8) div 2; - fillRect(tx-3, mY, Length(mTitle)*8+3+2, 8, TGxRGBA.Create(0, 0, 128)); - drawText8(tx, mY, mTitle, TGxRGBA.Create(r, g, b)); + fillRect(tx-3, mY, Length(mTitle)*8+3+2, 8, mBackColor[cidx]); + drawText8(tx, mY, mTitle, mFrameTextColor[cidx]); end; inherited drawControlPost(gx, gy); end; @@ -1845,7 +1969,14 @@ constructor TUIBox.Create (ahoriz: Boolean); begin inherited Create(); mHoriz := ahoriz; +end; + + +procedure TUIBox.AfterConstruction (); +begin + inherited AfterConstruction(); mCanFocus := false; + mCtl4Style := 'box'; end; @@ -1861,7 +1992,7 @@ begin end; if (strEquCI1251(prname, 'title')) or (strEquCI1251(prname, 'caption')) then begin - mCaption := par.expectStrOrId(true); + mCaption := par.expectIdOrStr(true); mDefSize := TLaySize.Create(Length(mCaption)*8+3, 8); result := true; exit; @@ -1878,22 +2009,23 @@ end; procedure TUIBox.drawControl (gx, gy: Integer); var - r, g, b: Integer; + cidx: Integer; tx: Integer; begin - if focused then begin r := 255; g := 255; b := 255; end else begin r := 255; g := 255; b := 0; end; + cidx := getColorIndex; + fillRect(gx, gy, mWidth, mHeight, mBackColor[cidx]); if mHasFrame then begin // draw frame - drawRectUI(gx+3, gy+3, mWidth-6, mHeight-6, TGxRGBA.Create(r, g, b)); + drawRectUI(gx+3, gy+3, mWidth-6, mHeight-6, mFrameColor[cidx]); end; // draw caption if (Length(mCaption) > 0) then begin setScissor(mFrameWidth+1, 0, mWidth-mFrameWidth-2, 8); tx := gx+((mWidth-Length(mCaption)*8) div 2); - if mHasFrame then fillRect(tx-2, gy, Length(mCaption)*8+3, 8, TGxRGBA.Create(0, 0, 128)); - drawText8(tx, gy, mCaption, TGxRGBA.Create(r, g, b)); + if mHasFrame then fillRect(tx-2, gy, Length(mCaption)*8+3, 8, mBackColor[cidx]); + drawText8(tx, gy, mCaption, mFrameTextColor[cidx]); end; end; @@ -1930,7 +2062,6 @@ procedure TUIVBox.AfterConstruction (); begin inherited AfterConstruction(); mHoriz := false; - mCanFocus := false; end; @@ -1940,6 +2071,7 @@ begin inherited AfterConstruction(); mExpand := true; mCanFocus := false; + mCtl4Style := 'span'; end; @@ -1956,6 +2088,15 @@ end; // ////////////////////////////////////////////////////////////////////// // +procedure TUILine.AfterConstruction (); +begin + inherited AfterConstruction(); + mExpand := true; + mCanFocus := false; + mCtl4Style := 'line'; +end; + + function TUILine.parseProperty (const prname: AnsiString; par: TTextParser): Boolean; begin if (parseOrientation(prname, par)) then begin result := true; exit; end; @@ -1964,14 +2105,17 @@ end; procedure TUILine.drawControl (gx, gy: Integer); +var + cidx: Integer; begin + cidx := getColorIndex; if mHoriz then begin - drawHLine(gx, gy+(mHeight div 2), mWidth, TGxRGBA.Create(255, 255, 255)); + drawHLine(gx, gy+(mHeight div 2), mWidth, mTextColor[cidx]); end else begin - drawVLine(gx+(mWidth div 2), gy, mHeight, TGxRGBA.Create(255, 255, 255)); + drawVLine(gx+(mWidth div 2), gy, mHeight, mTextColor[cidx]); end; end; @@ -1979,8 +2123,8 @@ end; // ////////////////////////////////////////////////////////////////////////// // procedure TUIHLine.AfterConstruction (); begin + inherited AfterConstruction(); mHoriz := true; - mExpand := true; mDefSize.h := 1; end; @@ -1988,10 +2132,9 @@ end; // ////////////////////////////////////////////////////////////////////////// // procedure TUIVLine.AfterConstruction (); begin + inherited AfterConstruction(); mHoriz := false; - mExpand := true; mDefSize.w := 1; - //mDefSize.h := 8; end; @@ -2011,6 +2154,7 @@ begin mVAlign := 0; mCanFocus := false; if (mDefSize.h <= 0) then mDefSize.h := 8; + mCtl4Style := 'label'; end; @@ -2018,7 +2162,7 @@ function TUITextLabel.parseProperty (const prname: AnsiString; par: TTextParser) begin if (strEquCI1251(prname, 'title')) or (strEquCI1251(prname, 'caption')) then begin - mText := par.expectStrOrId(true); + mText := par.expectIdOrStr(true); mDefSize := TLaySize.Create(Length(mText)*8, 8); result := true; exit; @@ -2036,11 +2180,10 @@ end; procedure TUITextLabel.drawControl (gx, gy: Integer); var xpos, ypos: Integer; + cidx: Integer; begin - // debug - fillRect(gx, gy, mWidth, mHeight, TGxRGBA.Create(96, 96, 0)); - drawRectUI(gx, gy, mWidth, mHeight, TGxRGBA.Create(96, 96, 96)); - + cidx := getColorIndex; + fillRect(gx, gy, mWidth, mHeight, mBackColor[cidx]); if (Length(mText) > 0) then begin if (mHAlign < 0) then xpos := 0 @@ -2051,7 +2194,7 @@ begin else if (mVAlign > 0) then ypos := mHeight-8 else ypos := (mHeight-8) div 2; - drawText8(gx+xpos, gy+ypos, mText, TGxRGBA.Create(255, 255, 255)); + drawText8(gx+xpos, gy+ypos, mText, mTextColor[cidx]); end; end; diff --git a/src/gx/gh_ui_style.pas b/src/gx/gh_ui_style.pas new file mode 100644 index 0000000..34e5f50 --- /dev/null +++ b/src/gx/gh_ui_style.pas @@ -0,0 +1,615 @@ +(* coded by Ketmar // Invisible Vector + * Understanding is not required. Only obedience. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + *) +{$INCLUDE ../../shared/a_modes.inc} +unit gh_ui_style; + +interface + +uses + SysUtils, Classes, + glgfx, + xstreams, xparser, utils, hashtable; + + +type + TStyleValue = packed record + public + type TType = (Empty, Bool, Int, Color); + + public + constructor Create (v: Boolean; okToInherit: Boolean=true); + constructor Create (v: Integer; okToInherit: Boolean=true); + constructor Create (ar, ag, ab: Integer; okToInherit: Boolean=true); + constructor Create (ar, ag, ab, aa: Integer; okToInherit: Boolean=true); + constructor Create (const v: TGxRGBA; okToInherit: Boolean=true); + + function isEmpty (): Boolean; inline; + function canInherit (): Boolean; inline; + + function toString (): AnsiString; + function asRGBA: TGxRGBA; inline; + function asRGBADef (const def: TGxRGBA): TGxRGBA; inline; + function asIntDef (const def: Integer): Integer; inline; + function asBoolDef (const def: Boolean): Boolean; inline; + + public + vtype: TType; + allowInherit: Boolean; + case TType of + TType.Bool: (bval: Boolean); + TType.Int: (ival: Integer); + TType.Color: (r, g, b, a: Byte); + end; + + TStyleSection = class; + + THashStrStyleVal = specialize THashBase; + THashStrSection = specialize THashBase; + + TStyleSection = class + private + mVals: THashStrStyleVal; + mHashVals: THashStrSection; // "#..." + mCtlVals: THashStrSection; + + private + // "text-color#inactive@label" + function getValue (const path: AnsiString): TStyleValue; + procedure putValue (const path: AnsiString; const val: TStyleValue); + + public + constructor Create (); + destructor Destroy (); override; + + public + property value[const path: AnsiString]: TStyleValue read getValue write putValue; default; + end; + + TUIStyle = class + private + mId: AnsiString; // style name ('default', for example) + mMain: TStyleSection; + + private + procedure parse (par: TTextParser); + + function getValue (const path: AnsiString): TStyleValue; inline; + procedure putValue (const path: AnsiString; const val: TStyleValue); inline; + + public + constructor Create (const aid: AnsiString); + constructor Create (st: TStream); // parse from stream + constructor CreateFromFile (const fname: AnsiString); + destructor Destroy (); override; + + public + property id: AnsiString read mId; + property value[const path: AnsiString]: TStyleValue read getValue write putValue; default; + end; + + +procedure uiLoadStyles (const fname: AnsiString); +procedure uiLoadStyles (st: TStream); + +// will return "default" (or raise an exception if there is no "default") +function uiFindStyle (const stname: AnsiString): TUIStyle; + + +implementation + + +// ////////////////////////////////////////////////////////////////////////// // +var + styles: array of TUIStyle = nil; + + +function createDefaultStyle (): TUIStyle; +begin + result := TUIStyle.Create('default'); + + result['back-color'] := TStyleValue.Create(TGxRGBA.Create(0, 0, 128)); + result['text-color'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255)); + result['frame-color'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255)); + result['frame-text-color'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255)); + result['frame-icon-color'] := TStyleValue.Create(TGxRGBA.Create(0, 255, 0)); + + // disabled is always inactive too + result['back-color#disabled'] := TStyleValue.Create(TGxRGBA.Create(0, 0, 128)); + result['text-color#disabled'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127)); + result['frame-text-color#disabled'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127)); + result['frame-icon-color#disabled'] := TStyleValue.Create(TGxRGBA.Create(0, 127, 0)); + result['darken#disabled'] := TStyleValue.Create(128, false); // darken inactive windows, no-inherit + result['darken#inactive'] := TStyleValue.Create(128, false); // darken inactive windows, no-inherit + + result['text-color@label'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 255)); + result['text-color#disabled@label'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127)); + + result['frame-color@box'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 0)); + result['frame-text-color@box'] := TStyleValue.Create(TGxRGBA.Create(255, 255, 0)); + result['frame-icon-color@box'] := TStyleValue.Create(TGxRGBA.Create(0, 255, 0)); + + result['frame-color#disabled@box'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127)); + result['frame-text-color#disabled@box'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127)); + result['frame-icon-color#disabled@box'] := TStyleValue.Create(TGxRGBA.Create(127, 127, 127)); +end; + + +function uiFindStyle (const stname: AnsiString): TUIStyle; +var + stl: TUIStyle; +begin + if (Length(stname) > 0) then + begin + for stl in styles do if (strEquCI1251(stl.mId, stname)) then begin result := stl; exit; end; + end; + for stl in styles do if (strEquCI1251(stl.mId, 'default')) then begin result := stl; exit; end; + stl := createDefaultStyle(); + SetLength(styles, Length(styles)+1); + styles[High(styles)] := stl; + result := stl; +end; + + +procedure uiLoadStyles (const fname: AnsiString); +var + st: TStream; +begin + st := openDiskFileRO(fname); + try + uiLoadStyles(st); + finally + st.Free(); + end; +end; + + +procedure uiLoadStyles (st: TStream); +var + par: TTextParser; + stl: TUIStyle = nil; + f: Integer; +begin + if (st = nil) then raise Exception.Create('cannot load UI styles from nil stream'); + par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId]); + styles := nil; + try + while (not par.isEOF) do + begin + stl := TUIStyle.Create(''); + stl.parse(par); + //writeln('new style: <', stl.mId, '>'); + f := 0; + while (f < Length(styles)) do begin if (strEquCI1251(styles[f].mId, stl.mId)) then break; Inc(f); end; + if (f < Length(styles)) then + begin + FreeAndNil(styles[f]); + end + else + begin + f := Length(styles); + SetLength(styles, f+1); + end; + styles[f] := stl; + stl := nil; + end; + finally + stl.Free(); + par.Free(); + end; + // we should have "default" style + for f := 0 to High(styles) do if (strEquCI1251(styles[f].mId, 'default')) then exit; + stl := createDefaultStyle(); + SetLength(styles, Length(styles)+1); + styles[High(styles)] := stl; +end; + + +// ////////////////////////////////////////////////////////////////////////// // +constructor TStyleValue.Create (v: Boolean; okToInherit: Boolean=true); begin vtype := TType.Bool; allowInherit := okToInherit; bval := v; end; +constructor TStyleValue.Create (v: Integer; okToInherit: Boolean=true); begin vtype := TType.Int; allowInherit := okToInherit; ival := v; end; + +constructor TStyleValue.Create (ar, ag, ab: Integer; okToInherit: Boolean=true); +begin + vtype := TType.Color; + allowInherit := okToInherit; + r := nmax(0, nmin(ar, 255)); + g := nmax(0, nmin(ag, 255)); + b := nmax(0, nmin(ab, 255)); + a := 255; +end; + +constructor TStyleValue.Create (ar, ag, ab, aa: Integer; okToInherit: Boolean=true); +begin + vtype := TType.Color; + allowInherit := okToInherit; + r := nmax(0, nmin(ar, 255)); + g := nmax(0, nmin(ag, 255)); + b := nmax(0, nmin(ab, 255)); + a := nmax(0, nmin(aa, 255)); +end; + +constructor TStyleValue.Create (const v: TGxRGBA; okToInherit: Boolean=true); +begin + vtype := TType.Color; + allowInherit := okToInherit; + r := v.r; + g := v.g; + b := v.b; + a := v.a; +end; + +function TStyleValue.isEmpty (): Boolean; inline; begin result := (vtype = TType.Empty); end; +function TStyleValue.canInherit (): Boolean; inline; begin result := allowInherit; end; +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; +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; +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; +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; + + +function TStyleValue.toString (): AnsiString; +begin + case vtype of + TType.Empty: result := ''; + TType.Bool: if bval then result := 'true' else result := 'false'; + TType.Int: result := formatstrf('%s', [ival]); + 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]); + else result := ''; + end; +end; + + +// ////////////////////////////////////////////////////////////////////////// // +procedure freeSectionCB (var v: TStyleSection); begin FreeAndNil(v); end; + + +function splitPath (const path: AnsiString; out name, hash, ctl: AnsiString): Boolean; +var + hashPos, atPos: Integer; +begin + result := false; + name := ''; + hash := ''; + ctl := ''; + hashPos := pos('#', path); + atPos := pos('@', path); + // split + if (atPos > 0) then + begin + // has ctl, and (possible) hash + if (hashPos > 0) then + begin + // has ctl and hash + if (atPos < hashPos) then exit; // alas + if (hashPos > 1) then name := Copy(path, 1, hashPos-1); + Inc(hashPos); // skip hash + if (hashPos < atPos) then hash := Copy(path, hashPos, atPos-hashPos); + end + else + begin + // has only ctl + if (atPos > 1) then name := Copy(path, 1, atPos-1); + end; + Inc(atPos); // skip "at" + if (atPos <= Length(path)) then ctl := Copy(path, atPos, Length(path)-atPos+1); + end + else if (hashPos > 0) then + begin + // has hash + if (hashPos > 1) then name := Copy(path, 1, hashPos-1); + Inc(hashPos); // skip hash + if (hashPos <= Length(path)) then hash := Copy(path, hashPos, Length(path)-hashPos+1); + end + else + begin + // only name + name := path; + end; + result := true; +end; + + +// ////////////////////////////////////////////////////////////////////////// // +constructor TStyleSection.Create (); +begin + mVals := THashStrStyleVal.Create(); + mHashVals := THashStrSection.Create(); + mCtlVals := THashStrSection.Create(freeSectionCB); +end; + + +destructor TStyleSection.Destroy (); +begin + FreeAndNil(mVals); + FreeAndNil(mHashVals); + FreeAndNil(mCtlVals); + inherited; +end; + + +// "text-color#inactive@label" +function TStyleSection.getValue (const path: AnsiString): TStyleValue; +var + name, hash, ctl: AnsiString; + sect: TStyleSection = nil; + s1: TStyleSection = nil; + checkInheritance: Boolean = false; +begin + result.vtype := result.TType.Empty; + if (not splitPath(path, name, hash, ctl)) then exit; // alas + //writeln('name:<', name, '>; hash:<', hash, '>; ctl:<', ctl, '>'); + if (Length(name) = 0) then exit; // alas + // try control + if (Length(ctl) > 0) then + begin + // has ctl section? + if not mCtlVals.get(ctl, sect) then + begin + sect := self; + checkInheritance := true; + end; + end + else + begin + sect := self; + end; + // has hash? + if (Length(hash) > 0) then + begin + if sect.mHashVals.get(hash, s1) then + begin + if s1.mVals.get(name, result) then + begin + //writeln('hash: <', hash, '>: val=', result.toString); + if (not result.isEmpty) and ((not checkInheritance) or (result.canInherit)) then exit; + end; + end; + //writeln('NO hash: <', hash, '>: val=', result.toString); + checkInheritance := true; + end; + // try just a name + if sect.mVals.get(name, result) then + begin + if (not result.isEmpty) and ((not checkInheritance) or (result.canInherit)) then exit; + end; + // alas + result.vtype := result.TType.Empty; +end; + + +procedure TStyleSection.putValue (const path: AnsiString; const val: TStyleValue); +var + name, hash, ctl: AnsiString; + sect: TStyleSection = nil; + s1: TStyleSection = nil; +begin + if (not splitPath(path, name, hash, ctl)) then exit; // alas + // has name? + if (Length(name) = 0) then exit; // no name -> nothing to do + // has ctl? + if (Length(ctl) > 0) then + begin + if not mCtlVals.get(ctl, sect) then + begin + // create new section + sect := TStyleSection.Create(); + mCtlVals.put(ctl, sect); + end; + end + else + begin + // no ctl, use default section + sect := self; + end; + // has hash? + if (Length(hash) > 0) then + begin + if not sect.mHashVals.get(hash, s1) then + begin + // create new section + s1 := TStyleSection.Create(); + mHashVals.put(hash, s1); + end; + end + else + begin + // no hash, use default section + s1 := sect; + end; + s1.mVals.put(name, val); +end; + + +// ////////////////////////////////////////////////////////////////////////// // +constructor TUIStyle.Create (const aid: AnsiString); +begin + mId := aid; + mMain := TStyleSection.Create(); +end; + + +constructor TUIStyle.Create (st: TStream); // parse from stream +var + par: TTextParser; +begin + mId := ''; + mMain := TStyleSection.Create(); + if (st = nil) then exit; + par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId]); + try + parse(par); + finally + par.Free(); + end; +end; + + +constructor TUIStyle.CreateFromFile (const fname: AnsiString); +var + par: TTextParser; + st: TStream; +begin + mId := ''; + mMain := TStyleSection.Create(); + st := openDiskFileRO(fname); + try + par := TFileTextParser.Create(st, false, [par.TOption.SignedNumbers, par.TOption.DollarIsId, par.TOption.DashIsId]); + try + parse(par); + finally + par.Free(); + end; + finally + st.Free(); + end; +end; + + +destructor TUIStyle.Destroy (); +begin + mId := ''; + FreeAndNil(mMain); +end; + + +function TUIStyle.getValue (const path: AnsiString): TStyleValue; inline; +begin + result := mMain[path]; +end; + +procedure TUIStyle.putValue (const path: AnsiString; const val: TStyleValue); inline; +begin + mMain.putValue(path, val); +end; + + +procedure TUIStyle.parse (par: TTextParser); + function getByte (): Byte; + begin + if (par.tokType <> par.TTInt) then par.expectInt(); + if (par.tokInt < 0) or (par.tokInt > 255) then par.error('invalid byte value'); + result := Byte(par.tokInt); + par.skipToken(); + end; + + procedure parseSection (sect: TStyleSection; ctlAllowed: Boolean; hashAllowed: Boolean); + var + s: AnsiString; + sc: TStyleSection = nil; + v: TStyleValue; + begin + par.expectDelim('{'); + while (not par.isDelim('}')) do + begin + while (par.eatDelim(';')) do begin end; + // hash + if hashAllowed and (par.eatDelim('#')) then + begin + s := par.expectIdOrStr(); + //writeln('hash: <', s, '>'); + par.eatDelim(':'); // optional + if not sect.mHashVals.get(s, sc) then + begin + // create new section + sc := TStyleSection.Create(); + sect.mHashVals.put(s, sc); + end; + parseSection(sc, false, false); + continue; + end; + // ctl + if ctlAllowed and (par.eatDelim('@')) then + begin + s := par.expectIdOrStr(); + //writeln('ctl: <', s, '>'); + par.eatDelim(':'); // optional + if not sect.mCtlVals.get(s, sc) then + begin + // create new section + sc := TStyleSection.Create(); + sect.mCtlVals.put(s, sc); + end; + parseSection(sc, false, true); + continue; + end; + // name + s := par.expectIdOrStr(); + //writeln('name: <', s, '>'); + v.allowInherit := true; + par.expectDelim(':'); + if (par.eatId('rgb')) or (par.eatId('rgba')) then + begin + // color + par.expectDelim('('); + v.vtype := v.TType.Color; + v.r := getByte(); par.eatDelim(','); // optional + v.g := getByte(); par.eatDelim(','); // optional + v.b := getByte(); par.eatDelim(','); // optional + if (par.tokType = par.TTInt) then + begin + v.a := getByte(); par.eatDelim(','); // optional + end + else + begin + v.a := 255; // opaque + end; + par.expectDelim(')'); + end + else if (par.eatId('true')) or (par.eatId('tan')) then + begin + v.vtype := v.TType.Bool; + v.bval := true; + end + else if (par.eatId('false')) or (par.eatId('ona')) then + begin + v.vtype := v.TType.Bool; + v.bval := false; + end + else + begin + // should be int + v.vtype := v.TType.Int; + v.ival := par.expectInt(); + end; + // '!' flags + while (par.eatDelim('!')) do + begin + if (par.eatId('no-inherit')) then v.allowInherit := false + else par.error('unknown flag'); + end; + par.expectDelim(';'); + sect.mVals.put(s, v); + end; + par.expectDelim('}'); + end; + +begin + // style name + if (not par.isIdOrStr) then + begin + if (Length(mId) = 0) then par.error('style name expected'); + end + else + begin + mId := par.tokStr; + end; + if (Length(mId) = 0) then mId := 'default'; + par.skipToken(); + parseSection(mMain, true, true); +end; + + +end. diff --git a/src/shared/hashtable.pas b/src/shared/hashtable.pas index 33920a1..1e0cd97 100644 --- a/src/shared/hashtable.pas +++ b/src/shared/hashtable.pas @@ -194,6 +194,14 @@ type class procedure freekey (var k: AnsiString); inline; end; + // case-insensitive (ansi) + THashKeyStrAnsiCI = class + public + class function hash (const k: AnsiString): LongWord; inline; + class function equ (const a, b: AnsiString): Boolean; inline; + class procedure freekey (var k: AnsiString); inline; + end; + type THashIntInt = specialize THashBase; THashStrInt = specialize THashBase; @@ -204,7 +212,7 @@ type function u32Hash (a: LongWord): LongWord; inline; function fnvHash (constref buf; len: LongWord): LongWord; -function joaatHash (constref buf; len: LongWord): LongWord; +function joaatHash (constref buf; len: LongWord; seed: LongWord=0): LongWord; // has to be public due to FPC generics limitation function nextPOTU32 (x: LongWord): LongWord; inline; @@ -281,17 +289,30 @@ end; {$POP} -function joaatHash (constref buf; len: LongWord): LongWord; +// ////////////////////////////////////////////////////////////////////////// // +{$PUSH} +{$RANGECHECKS OFF} +function joaatHash (constref buf; len: LongWord; seed: LongWord=0): LongWord; var - h: TJoaatHasher; + b: PByte; + f: LongWord; begin - h := TJoaatHasher.Create(0); - h.put(PByte(@buf)^, len); - result := h.value; + result := seed; + b := PByte(@buf); + for f := 1 to len do + begin + result += b^; + result += (result shl 10); + result := result xor (result shr 6); + Inc(b); + end; + // finalize + result += (result shl 3); + result := result xor (result shr 11); + result += (result shl 15); end; +{$POP} - -// ////////////////////////////////////////////////////////////////////////// // {$PUSH} {$RANGECHECKS OFF} // fnv-1a: http://www.isthe.com/chongo/tech/comp/fnv/ @@ -311,7 +332,6 @@ begin end; {$POP} - {$PUSH} {$RANGECHECKS OFF} function u32Hash (a: LongWord): LongWord; inline; @@ -327,6 +347,29 @@ begin end; {$POP} +function locase1251 (ch: AnsiChar): AnsiChar; inline; +begin + if ch < #128 then + begin + if (ch >= 'A') and (ch <= 'Z') then Inc(ch, 32); + end + else + begin + if (ch >= #192) and (ch <= #223) then + begin + Inc(ch, 32); + end + else + begin + case ch of + #168, #170, #175: Inc(ch, 16); + #161, #178: Inc(ch); + end; + end; + end; + result := ch; +end; + // ////////////////////////////////////////////////////////////////////////// // // THashKeyInt @@ -353,6 +396,42 @@ class function THashKeyStr.equ (const a, b: AnsiString): Boolean; inline; begin class procedure THashKeyStr.freekey (var k: AnsiString); inline; begin k := ''; end; +// ////////////////////////////////////////////////////////////////////////// // +// case-insensitive (ansi) +{$PUSH} +{$RANGECHECKS OFF} +// fnv-1a: http://www.isthe.com/chongo/tech/comp/fnv/ +function fnvHashLo (constref buf; len: LongWord): LongWord; +var + b: PAnsiChar; +begin + b := @buf; + result := 2166136261; // fnv offset basis + while (len > 0) do + begin + result := result xor Byte(locase1251(b^)); + result := result*16777619; // 32-bit fnv prime + Inc(b); + Dec(len); + end; +end; +{$POP} + +class function THashKeyStrAnsiCI.hash (const k: AnsiString): LongWord; inline; begin if (Length(k) > 0) then result := fnvHash((@k[1])^, Length(k)) else result := 0; end; +class function THashKeyStrAnsiCI.equ (const a, b: AnsiString): Boolean; inline; +var + f: Integer; +begin + result := false; + if (Length(a) = Length(b)) then + begin + for f := 1 to Length(a) do if (locase1251(a[f]) <> locase1251(b[f])) then exit; + end; + result := true; +end; +class procedure THashKeyStrAnsiCI.freekey (var k: AnsiString); inline; begin k := ''; end; + + // ////////////////////////////////////////////////////////////////////////// // function THashBase.TEntry.getEmpty (): Boolean; inline; begin result := (hash = 0); end; @@ -366,6 +445,7 @@ begin freevalfn := afreevalfn; mSeed := u32Hash($29a); + mFreeEntryHead := nil; mFirstEntry := -1; mLastEntry := -1; clear(); @@ -374,6 +454,7 @@ end; destructor THashBase.Destroy (); begin + freeEntries(); mBuckets := nil; mEntries := nil; inherited; @@ -414,14 +495,19 @@ end; procedure THashBase.clear (); -//var idx: Integer; begin freeEntries(); + { SetLength(mBuckets, InitSize); FillChar(mBuckets[0], InitSize*sizeof(mBuckets[0]), 0); - //for idx := 0 to High(mBuckets) do mBuckets[idx] := nil; SetLength(mEntries, InitSize); FillChar(mEntries[0], InitSize*sizeof(mEntries[0]), 0); + } + mFreeEntryHead := nil; + mBuckets := nil; + mEntries := nil; + mFirstEntry := -1; + mLastEntry := -1; mBucketsUsed := 0; end; @@ -445,6 +531,21 @@ var begin if (mFreeEntryHead = nil) then begin + // nothing was allocated, so allocate something now + if (Length(mBuckets) = 0) then + begin + assert(Length(mEntries) = 0); + assert(mFirstEntry = -1); + assert(mLastEntry = -1); + assert(mBucketsUsed = 0); + {$IFDEF RBHASH_SANITY_CHECKS} + mEntriesUsed := 0; + {$ENDIF} + SetLength(mBuckets, InitSize); + FillChar(mBuckets[0], InitSize*sizeof(mBuckets[0]), 0); + SetLength(mEntries, InitSize); + FillChar(mEntries[0], InitSize*sizeof(mEntries[0]), 0); + end; if (mLastEntry = High(mEntries)) then raise Exception.Create('internal error in hash entry allocator (0.0)'); Inc(mLastEntry); if (mFirstEntry = -1) then diff --git a/src/shared/utils.pas b/src/shared/utils.pas index 308293d..59a49f2 100644 --- a/src/shared/utils.pas +++ b/src/shared/utils.pas @@ -81,15 +81,15 @@ function isWadPath (const fn: AnsiString): Boolean; function addWadExtension (const fn: AnsiString): AnsiString; // convert number to strig with nice commas -function Int64ToStrComma (i: Int64): AnsiString; +function int64ToStrComma (i: Int64): AnsiString; -function UpCase1251 (ch: Char): Char; -function LoCase1251 (ch: Char): Char; +function upcase1251 (ch: AnsiChar): AnsiChar; inline; +function locase1251 (ch: AnsiChar): AnsiChar; inline; function toLowerCase1251 (const s: AnsiString): AnsiString; // `true` if strings are equal; ignoring case for cp1251 -function StrEquCI1251 (const s0, s1: AnsiString): Boolean; +function strEquCI1251 (const s0, s1: AnsiString): Boolean; function utf8Valid (const s: AnsiString): Boolean; @@ -537,25 +537,25 @@ var if (code < 0) or (code > $10FFFF) then begin result := '?'; exit; end; if (code <= $7f) then begin - result := Char(code and $ff); + result := AnsiChar(code and $ff); end else if (code <= $7FF) then begin - result := Char($C0 or (code shr 6)); - result += Char($80 or (code and $3F)); + result := AnsiChar($C0 or (code shr 6)); + result += AnsiChar($80 or (code and $3F)); end else if (code <= $FFFF) then begin - result := Char($E0 or (code shr 12)); - result += Char($80 or ((code shr 6) and $3F)); - result += Char($80 or (code and $3F)); + result := AnsiChar($E0 or (code shr 12)); + result += AnsiChar($80 or ((code shr 6) and $3F)); + result += AnsiChar($80 or (code and $3F)); end else if (code <= $10FFFF) then begin - result := Char($F0 or (code shr 18)); - result += Char($80 or ((code shr 12) and $3F)); - result += Char($80 or ((code shr 6) and $3F)); - result += Char($80 or (code and $3F)); + result := AnsiChar($F0 or (code shr 18)); + result += AnsiChar($80 or ((code shr 12) and $3F)); + result += AnsiChar($80 or ((code shr 6) and $3F)); + result += AnsiChar($80 or (code and $3F)); end else begin @@ -844,7 +844,7 @@ begin end; -function Int64ToStrComma (i: Int64): AnsiString; +function int64ToStrComma (i: Int64): AnsiString; var f: Integer; begin @@ -857,7 +857,7 @@ begin end; -function UpCase1251 (ch: Char): Char; +function upcase1251 (ch: AnsiChar): AnsiChar; inline; begin if ch < #128 then begin @@ -881,7 +881,7 @@ begin end; -function LoCase1251 (ch: Char): Char; +function locase1251 (ch: AnsiChar): AnsiChar; inline; begin if ch < #128 then begin @@ -905,7 +905,7 @@ begin end; -function StrEquCI1251 (const s0, s1: AnsiString): Boolean; +function strEquCI1251 (const s0, s1: AnsiString): Boolean; var i: Integer; begin @@ -991,7 +991,7 @@ const ); -function decodeUtf8Char (s: AnsiString; var pos: Integer): char; +function decodeUtf8Char (s: AnsiString; var pos: Integer): AnsiChar; var b, c: Integer; begin @@ -1009,7 +1009,7 @@ begin b := Byte(s[pos]); Inc(pos); - if b < $80 then begin result := char(b); exit; end; + if b < $80 then begin result := AnsiChar(b); exit; end; // mask out unused bits if (b and $FE) = $FC then b := b and $01 @@ -1030,7 +1030,7 @@ begin end; // done, try 1251 - for c := 128 to 255 do if uni2wint[c] = b then begin result := char(c and $FF); exit; end; + for c := 128 to 255 do if uni2wint[c] = b then begin result := AnsiChar(c and $FF); exit; end; // alas end; @@ -1186,7 +1186,7 @@ end; function checkSign (st: TStream; const sign: AnsiString): Boolean; var - buf: packed array[0..7] of Char; + buf: packed array[0..7] of AnsiChar; f: Integer; begin result := false; diff --git a/src/shared/xdynrec.pas b/src/shared/xdynrec.pas index 7d1098e..4676ae7 100644 --- a/src/shared/xdynrec.pas +++ b/src/shared/xdynrec.pas @@ -1180,7 +1180,7 @@ begin ahelp := ''; // field name - fldname := pr.expectStrOrId(); + fldname := pr.expectIdOrStr(); while (not pr.isDelim(';')) do begin @@ -2612,7 +2612,7 @@ begin end else begin - mTypeName := pr.expectStrOrId(); + mTypeName := pr.expectIdOrStr(); while (not pr.isDelim('{')) do begin if pr.eatId('header') then begin mHeader := true; continue; end; diff --git a/src/shared/xparser.pas b/src/shared/xparser.pas index 4e45fc6..5332f0a 100644 --- a/src/shared/xparser.pas +++ b/src/shared/xparser.pas @@ -65,6 +65,7 @@ type SignedNumbers, // allow signed numbers; otherwise sign will be TTDelim DollarIsId, // allow dollar in identifiers; otherwise dollar will be TTDelim DotIsId, // allow dot in identifiers; otherwise dot will be TTDelim + DashIsId, // '-' can be part of identifier (but identifier cannot start with '-') PascalComments // allow `{}` pascal comments ); TOptions = set of TOption; @@ -118,7 +119,7 @@ type function expectStr (allowEmpty: Boolean=false): AnsiString; function expectInt (): Integer; - function expectStrOrId (allowEmpty: Boolean=false): AnsiString; + function expectIdOrStr (allowEmpty: Boolean=false): AnsiString; procedure expectTT (ttype: Integer); function eatTT (ttype: Integer): Boolean; @@ -306,7 +307,7 @@ begin end; -function TTextParser.isEOF (): Boolean; inline; begin result := (mCurChar = #0); end; +function TTextParser.isEOF (): Boolean; inline; begin {result := (mCurChar = #0);} result := (mTokType = TTEOF); end; procedure TTextParser.warmup (); @@ -339,26 +340,26 @@ function TTextParser.skipBlanks (): Boolean; var level: Integer; begin - while not isEOF do + while (mCurChar <> #0) do begin - if (curChar = '/') then + if (mCurChar = '/') then begin // single-line comment - if (nextChar = '/') then + if (mNextChar = '/') then begin - while not isEOF and (curChar <> #10) do skipChar(); + while (mCurChar <> #0) and (mCurChar <> #10) do skipChar(); skipChar(); // skip EOL continue; end; // multline comment - if (nextChar = '*') then + if (mNextChar = '*') then begin // skip comment start skipChar(); skipChar(); - while not isEOF do + while (mCurChar <> #0) do begin - if (curChar = '*') and (nextChar = '/') then + if (mCurChar = '*') and (mNextChar = '/') then begin // skip comment end skipChar(); @@ -370,15 +371,15 @@ begin continue; end; // nesting multline comment - if (nextChar = '+') then + if (mNextChar = '+') then begin // skip comment start skipChar(); skipChar(); level := 1; - while not isEOF do + while (mCurChar <> #0) do begin - if (curChar = '+') and (nextChar = '/') then + if (mCurChar = '+') and (mNextChar = '/') then begin // skip comment end skipChar(); @@ -387,7 +388,7 @@ begin if (level = 0) then break; continue; end; - if (curChar = '/') and (nextChar = '+') then + if (mCurChar = '/') and (mNextChar = '+') then begin // skip comment start skipChar(); @@ -400,14 +401,14 @@ begin continue; end; end - else if (curChar = '(') and (nextChar = '*') then + else if (mCurChar = '(') and (mNextChar = '*') then begin // pascal comment; skip comment start skipChar(); skipChar(); - while not isEOF do + while (mCurChar <> #0) do begin - if (curChar = '*') and (nextChar = ')') then + if (mCurChar = '*') and (mNextChar = ')') then begin // skip comment end skipChar(); @@ -418,13 +419,13 @@ begin end; continue; end - else if (curChar = '{') and (TOption.PascalComments in mOptions) then + else if (mCurChar = '{') and (TOption.PascalComments in mOptions) then begin // pascal comment; skip comment start skipChar(); - while not isEOF do + while (mCurChar <> #0) do begin - if (curChar = '}') then + if (mCurChar = '}') then begin // skip comment end skipChar(); @@ -434,10 +435,10 @@ begin end; continue; end; - if (curChar > ' ') then break; + if (mCurChar > ' ') then break; skipChar(); // skip blank end; - result := not isEOF; + result := (mCurChar <> #0); end; @@ -461,11 +462,11 @@ function TTextParser.skipToken (): Boolean; begin if (TOption.SignedNumbers in mOptions) then begin - if (curChar = '+') or (curChar = '-') then + if (mCurChar = '+') or (mCurChar = '-') then begin - neg := (curChar = '-'); + neg := (mCurChar = '-'); skipChar(); - if (curChar < '0') or (curChar > '9') then + if (mCurChar < '0') or (mCurChar > '9') then begin mTokType := TTDelim; if (neg) then mTokChar := '-' else mTokChar := '+'; @@ -473,9 +474,9 @@ function TTextParser.skipToken (): Boolean; end; end; end; - if (curChar = '0') then + if (mCurChar = '0') then begin - case nextChar of + case mNextChar of 'b','B': base := 2; 'o','O': base := 8; 'd','D': base := 10; @@ -490,12 +491,12 @@ function TTextParser.skipToken (): Boolean; end; // default base if (base < 0) then base := 10; - if (digitInBase(curChar, base) < 0) then raise Exception.Create('invalid number'); + if (digitInBase(mCurChar, base) < 0) then raise Exception.Create('invalid number'); mTokType := TTInt; mTokInt := 0; // just in case - while not isEOF do + while (mCurChar <> #0) do begin - n := digitInBase(curChar, base); + n := digitInBase(mCurChar, base); if (n < 0) then break; n := mTokInt*10+n; if (n < 0) or (n < mTokInt) then raise Exception.Create('integer overflow'); @@ -503,10 +504,10 @@ function TTextParser.skipToken (): Boolean; skipChar(); end; // check for valid number end - if not isEOF then + if (mCurChar <> #0) then begin - if (curChar = '.') then raise Exception.Create('floating numbers aren''t supported yet'); - if (curChar = '_') or ((curChar >= 'A') and (curChar <= 'Z')) or ((curChar >= 'a') and (curChar <= 'z')) or (curChar >= #128) then + if (mCurChar = '.') then raise Exception.Create('floating numbers aren''t supported yet'); + if (mCurChar = '_') or ((mCurChar >= 'A') and (mCurChar <= 'Z')) or ((mCurChar >= 'a') and (mCurChar <= 'z')) or (mCurChar >= #128) then begin raise Exception.Create('invalid number'); end; @@ -521,15 +522,15 @@ function TTextParser.skipToken (): Boolean; begin mTokType := TTStr; mTokStr := ''; // just in case - qch := curChar; + qch := mCurChar; skipChar(); // skip starting quote - while not isEOF do + while (mCurChar <> #0) do begin // escape - if (qch = '"') and (curChar = '\') then + if (qch = '"') and (mCurChar = '\') then begin - if (nextChar = #0) then raise Exception.Create('unterminated string escape'); - ch := nextChar; + if (mNextChar = #0) then raise Exception.Create('unterminated string escape'); + ch := mNextChar; // skip backslash and escape type skipChar(); skipChar(); @@ -541,12 +542,12 @@ function TTextParser.skipToken (): Boolean; 'e': mTokStr += #27; 'x', 'X': // hex escape begin - n := digitInBase(curChar, 16); + n := digitInBase(mCurChar, 16); if (n < 0) then raise Exception.Create('invalid hexstr escape'); skipChar(); - if (digitInBase(curChar, 16) > 0) then + if (digitInBase(mCurChar, 16) > 0) then begin - n := n*16+digitInBase(curChar, 16); + n := n*16+digitInBase(mCurChar, 16); skipChar(); end; mTokStr += AnsiChar(n); @@ -556,7 +557,7 @@ function TTextParser.skipToken (): Boolean; continue; end; // duplicate single quote (pascal style) - if (qch = '''') and (curChar = '''') and (nextChar = '''') then + if (qch = '''') and (mCurChar = '''') and (mNextChar = '''') then begin // skip both quotes skipChar(); @@ -564,12 +565,12 @@ function TTextParser.skipToken (): Boolean; mTokStr += ''''; continue; end; - if (curChar = qch) then + if (mCurChar = qch) then begin skipChar(); // skip ending quote break; end; - mTokStr += curChar; + mTokStr += mCurChar; skipChar(); end; end; @@ -578,20 +579,21 @@ function TTextParser.skipToken (): Boolean; begin mTokType := TTId; mTokStr := ''; // just in case - while (curChar = '_') or ((curChar >= '0') and (curChar <= '9')) or - ((curChar >= 'A') and (curChar <= 'Z')) or - ((curChar >= 'a') and (curChar <= 'z')) or - (curChar >= #128) or - ((TOption.DollarIsId in mOptions) and (curChar = '$')) or - ((TOption.DotIsId in mOptions) and (curChar = '.') and (nextChar <> '.')) do + while (mCurChar = '_') or ((mCurChar >= '0') and (mCurChar <= '9')) or + ((mCurChar >= 'A') and (mCurChar <= 'Z')) or + ((mCurChar >= 'a') and (mCurChar <= 'z')) or + (mCurChar >= #128) or + ((TOption.DollarIsId in mOptions) and (mCurChar = '$')) or + ((TOption.DotIsId in mOptions) and (mCurChar = '.') and (mNextChar <> '.')) or + ((TOption.DashIsId in mOptions) and (mCurChar = '-')) do begin - mTokStr += curChar; + mTokStr += mCurChar; skipChar(); end; end; begin - mTokType := TTEOF; + mTokType := TTNone; mTokStr := ''; mTokChar := #0; mTokInt := 0; @@ -599,6 +601,7 @@ begin if not skipBlanks() then begin result := false; + mTokType := TTEOF; mTokLine := mLine; mTokCol := mCol; exit; @@ -610,22 +613,22 @@ begin result := true; // number? - if (TOption.SignedNumbers in mOptions) and ((curChar = '+') or (curChar = '-')) then begin parseInt(); exit; end; - if (curChar >= '0') and (curChar <= '9') then begin parseInt(); exit; end; + if (TOption.SignedNumbers in mOptions) and ((mCurChar = '+') or (mCurChar = '-')) then begin parseInt(); exit; end; + if (mCurChar >= '0') and (mCurChar <= '9') then begin parseInt(); exit; end; // string? - if (curChar = '"') or (curChar = '''') then begin parseString(); exit; end; + if (mCurChar = '"') or (mCurChar = '''') then begin parseString(); exit; end; // identifier? - if (curChar = '_') or ((curChar >= 'A') and (curChar <= 'Z')) or ((curChar >= 'a') and (curChar <= 'z')) or (curChar >= #128) then begin parseId(); exit; end; - if (TOption.DollarIsId in mOptions) and (curChar = '$') then begin parseId(); exit; end; - if (TOption.DotIsId in mOptions) and (curChar = '.') and (nextChar <> '.') then begin parseId(); exit; end; + if (mCurChar = '_') or ((mCurChar >= 'A') and (mCurChar <= 'Z')) or ((mCurChar >= 'a') and (mCurChar <= 'z')) or (mCurChar >= #128) then begin parseId(); exit; end; + if (TOption.DollarIsId in mOptions) and (mCurChar = '$') then begin parseId(); exit; end; + if (TOption.DotIsId in mOptions) and (mCurChar = '.') and (mNextChar <> '.') then begin parseId(); exit; end; // known delimiters? - mTokChar := curChar; + mTokChar := mCurChar; mTokType := TTDelim; skipChar(); - if (curChar = '=') then + if (mCurChar = '=') then begin case mTokChar of '<': begin mTokType := TTLessEqu; mTokStr := '<='; skipChar(); exit; end; @@ -635,7 +638,7 @@ begin ':': begin mTokType := TTAss; mTokStr := ':='; skipChar(); exit; end; end; end - else if (mTokChar = curChar) then + else if (mTokChar = mCurChar) then begin case mTokChar of '<': begin mTokType := TTShl; mTokStr := '<<'; skipChar(); exit; end; @@ -647,8 +650,8 @@ begin else begin case mTokChar of - '<': if (curChar = '>') then begin mTokType := TTNotEqu; mTokStr := '<>'; skipChar(); exit; end; - '.': if (curChar = '.') then begin mTokType := TTDotDot; mTokStr := '..'; skipChar(); exit; end; + '<': if (mCurChar = '>') then begin mTokType := TTNotEqu; mTokStr := '<>'; skipChar(); exit; end; + '.': if (mCurChar = '.') then begin mTokType := TTDotDot; mTokStr := '..'; skipChar(); exit; end; end; end; end; @@ -727,7 +730,7 @@ begin end; -function TTextParser.expectStrOrId (allowEmpty: Boolean=false): AnsiString; +function TTextParser.expectIdOrStr (allowEmpty: Boolean=false): AnsiString; begin case mTokType of TTStr: -- 2.29.2