X-Git-Url: http://deadsoftware.ru/gitweb?a=blobdiff_plain;f=src%2Fshared%2Fxdynrec.pas;h=db576f60bdfff249cd1b2b8de783cd315ff5615e;hb=11f1db221de3d7c80641b87194a920e54850b713;hp=6c4e376194b85e63beb7f3572b4cd389a5446e3e;hpb=6fdaf7454535407de0331bdc6b96e538919525a6;p=d2df-sdl.git diff --git a/src/shared/xdynrec.pas b/src/shared/xdynrec.pas index 6c4e376..db576f6 100644 --- a/src/shared/xdynrec.pas +++ b/src/shared/xdynrec.pas @@ -1,4 +1,4 @@ -(* Copyright (C) DooM 2D:Forever Developers +(* Copyright (C) Doom 2D: Forever Developers * * 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 @@ -21,6 +21,7 @@ interface uses SysUtils, Variants, Classes, + {$IFDEF USE_MEMPOOL}mempool,{$ENDIF} xparser, xstreams, utils, hashtable; @@ -54,10 +55,10 @@ type TDynEBSList = specialize TSimpleList; // this is base type for all scalars (and arrays) - TDynField = class + TDynField = class{$IFDEF USE_MEMPOOL}(TPoolObject){$ENDIF} public type - TType = (TBool, TChar, TByte, TUByte, TShort, TUShort, TInt, TUInt, TString, TPoint, TSize, TList, TTrigData); + TType = (TBool, TChar, TByte, TUByte, TShort, TUShort, TInt, TUInt, TString, TPoint, TSize, TColor, TList, TTrigData); // TPoint: pair of Integers // TSize: pair of UShorts // TList: actually, array of records @@ -71,9 +72,13 @@ type private mOwner: TDynRecord; // owner record mName: AnsiString; // field name + mTip: AnsiString; // short tip + mHelp: AnsiString; // long help mType: TType; // field type mIVal: Integer; // for all integer types mIVal2: Integer; // for point and size + mIVal3: Integer; // for TColor + mIVal4: Integer; // for TColor mSVal: AnsiString; // string; for byte and char arrays mRVal: TDynRecList; // for list mRHash: THashStrInt; // id -> index in mRVal @@ -92,7 +97,7 @@ type // default value mDefUnparsed: AnsiString; mDefSVal: AnsiString; // default string value - mDefIVal, mDefIVal2: Integer; // default integer values + mDefIVal, mDefIVal2, mDefIVal3, mDefIVal4: Integer; // default integer values mDefRecRef: TDynRecord; mEBS: TEBS; // complex type type mEBSTypeName: AnsiString; // name of enum, bitset or record @@ -132,6 +137,7 @@ type protected // returns `true` for duplicate record id function addListItem (rec: TDynRecord): Boolean; inline; + function removeListItem (const aid: AnsiString): TDynRecord; // returns nil or removed record public // get string name for the given type @@ -159,6 +165,18 @@ type // supports `for rec in field do` (for lists) function GetEnumerator (): TDynRecList.TEnumerator; inline; + function getRed (): Integer; inline; + procedure setRed (v: Integer); inline; + + function getGreen (): Integer; inline; + procedure setGreen (v: Integer); inline; + + function getBlue (): Integer; inline; + procedure setBlue (v: Integer); inline; + + function getAlpha (): Integer; inline; + procedure setAlpha (v: Integer); inline; + public // text parser and writer procedure parseValue (pr: TTextParser); @@ -166,7 +184,7 @@ type // binary parser and writer (DO NOT USE!) procedure parseBinValue (st: TStream); - procedure writeBinTo (st: TStream); + procedure writeBinTo (var hasLostData: Boolean; st: TStream); public // the following functions are here only for 'mapgen'! DO NOT USE! @@ -181,6 +199,12 @@ type property internal: Boolean read mInternal write mInternal; // internal field? property ival: Integer read mIVal; // integer value for int field (for speed), first field (x/w) for `TPoint` and `TSize` property ival2: Integer read mIVal2; // for `TPoint` and `TSize`, this is second field (y/h) + property ival3: Integer read mIVal3; // for `TColor`: blue + property ival4: Integer read mIVal4; // for `TColor`: alpha + property red: Integer read getRed write setRed; // for `TColor`: red + property green: Integer read getGreen write setGreen; // for `TColor`: green + property blue: Integer read getBlue write setBlue; // for `TColor`: blue + property alpha: Integer read getAlpha write setAlpha; // for `TColor`: alpha property sval: AnsiString read mSVal; // string value for string field (for speed) property hasDefault: Boolean read mHasDefault; // `true` if this field has default value in mapdef property defsval: AnsiString read mDefSVal; // string representation of default value @@ -196,6 +220,9 @@ type // field value as Variant property value: Variant read getVar write setVar; + property tip: AnsiString read mTip; + property help: AnsiString read mHelp; + public // userdata (you can use these properties as you want to; they won't be written or read to files) property tagInt: Integer read mTagInt write mTagInt; @@ -207,15 +234,18 @@ type property hasTPrefix: Boolean read mAsT; property separatePasFields: Boolean read mSepPosSize; property binOfs: Integer read mBinOfs; + property equToDefault: Boolean read isDefaultValue; end; // record, either with actual values, or with type definitions - TDynRecord = class + TDynRecord = class{$IFDEF USE_MEMPOOL}(TPoolObject){$ENDIF} private mOwner: TDynMapDef; mId: AnsiString; - mName: AnsiString; + mTypeName: AnsiString; + mTip: AnsiString; // short tip + mHelp: AnsiString; // long help mSize: Integer; mFields: TDynFieldList; {$IF DEFINED(XDYNREC_USE_FIELDHASH)} @@ -253,6 +283,8 @@ type function getUserVar (const aname: AnsiString): Variant; procedure setUserVar (const aname: AnsiString; val: Variant); + procedure clearRefRecs (rec: TDynRecord); + protected function findRecordByTypeId (const atypename, aid: AnsiString): TDynRecord; function findRecordNumByType (const atypename: AnsiString; rc: TDynRecord): Integer; @@ -283,8 +315,22 @@ type // only for headers: create new record with the given type // will return cloned record ready for use, or `nil` on unknown type name + // `aid` must not be empty, and must be unique function newTypedRecord (const atypename, aid: AnsiString): TDynRecord; + // remove record with the given type and id + // return `true` if record was successfully found and removed + // this will do all necessary recref cleanup too + // WARNING: not tested yet + function removeTypedRecord (const atypename, aid: AnsiString): Boolean; + + //TODO: + // [.] API to create triggers + // [.] API to properly remove triggers (remove trigdata) + // [.] check if `removeTypedRecord()` does the right thing with inline records + // [.] for fields: assigning `recref` should remove previously assigned inline record (record without id) + // [.] other API i forgot + public // text parser // `beginEaten`: `true` if "{" was eaten @@ -296,12 +342,12 @@ type // binary parser and writer (DO NOT USE!) procedure parseBinValue (st: TStream; forceData: Boolean=false); - procedure writeBinTo (st: TStream; trigbufsz: Integer=-1; onlyFields: Boolean=false); + procedure writeBinTo (var hasLostData: Boolean; st: TStream; trigbufsz: Integer=-1; onlyFields: Boolean=false); public property mapdef: TDynMapDef read mOwner; property id: AnsiString read mId; // record id in text map - property typeName: AnsiString read mName; // record type name (like "panel", or "trigger") + property typeName: AnsiString read mTypeName; // record type name (like "panel", or "trigger") property has[const aname: AnsiString]: Boolean read hasByName; // do we have field with the given name? property count: Integer read getCount; // number of fields in this record property field[const aname: AnsiString]: TDynField read getFieldByName; default; // get field by name @@ -313,6 +359,9 @@ type property headerRec: TDynRecord read mHeaderRec; // get header record for this one (header contains all other records, enums, bitsets, etc.) property isHeader: Boolean read mHeader; // is this a header record? + property tip: AnsiString read mTip; + property help: AnsiString read mHelp; + public // user fields; user can add arbitrary custom fields // by default, any user field will be marked as "internal" @@ -327,11 +376,13 @@ type // bitset/enum definition - TDynEBS = class + TDynEBS = class{$IFDEF USE_MEMPOOL}(TPoolObject){$ENDIF} private mOwner: TDynMapDef; mIsEnum: Boolean; - mName: AnsiString; + mTypeName: AnsiString; + mTip: AnsiString; // short tip + mHelp: AnsiString; // long help mIds: array of AnsiString; mVals: array of Integer; mMaxName: AnsiString; // MAX field @@ -359,15 +410,18 @@ type public property mapdef: TDynMapDef read mOwner; - property typeName: AnsiString read mName; // enum/bitset type name + property typeName: AnsiString read mTypeName; // enum/bitset type name property isEnum: Boolean read mIsEnum; // is this enum? `false` means "bitset" property has[const aname: AnsiString]: Boolean read hasByName; - property field[const aname: AnsiString]: Integer read getFieldByName; + property field[const aname: AnsiString]: Integer read getFieldByName; default; + + property tip: AnsiString read mTip; + property help: AnsiString read mHelp; end; // parsed "mapdef.txt" - TDynMapDef = class + TDynMapDef = class{$IFDEF USE_MEMPOOL}(TPoolObject){$ENDIF} public recTypes: TDynRecList; // [0] is always header trigTypes: TDynRecList; // trigdata @@ -404,7 +458,7 @@ type public // parse text or binary map, return new header record // WARNING! stream must be seekable - function parseMap (st: TStream): TDynRecord; + function parseMap (st: TStream; wasBinary: PBoolean=nil): TDynRecord; // returns `true` if the given stream can be a map file // stream position is 0 on return @@ -436,12 +490,15 @@ type procedure xdynDumpProfiles (); {$ENDIF} +var + DynWarningCB: procedure (const msg: AnsiString; line, col: Integer) = nil; implementation +{$IF DEFINED(D2D_DYNREC_PROFILER)} uses - e_log - {$IF DEFINED(D2D_DYNREC_PROFILER)},xprofiler{$ENDIF}; + xprofiler; +{$ENDIF} // ////////////////////////////////////////////////////////////////////////// // @@ -494,7 +551,7 @@ begin if (mType = TType.TList) then begin mRVal := TDynRecList.Create(); - mRHash := hashNewStrInt(); + mRHash := THashStrInt.Create(); end; end; @@ -582,9 +639,13 @@ end; procedure TDynField.cleanup (); begin mName := ''; + mTip := ''; + mHelp := ''; mType := TType.TInt; mIVal := 0; mIVal2 := 0; + mIVal3 := 0; + mIVal4 := 0; // default alpha value mSVal := ''; mRVal.Free(); mRVal := nil; @@ -603,6 +664,8 @@ begin mDefSVal := ''; mDefIVal := 0; mDefIVal2 := 0; + mDefIVal3 := 0; + mDefIVal4 := 0; // default value for alpha mDefRecRef := nil; mEBS := TEBS.TNone; mEBSTypeName := ''; @@ -625,14 +688,18 @@ begin result.mOwner := mOwner; if (newOwner <> nil) then result.mOwner := newOwner else result.mOwner := mOwner; result.mName := mName; + result.mTip := mTip; + result.mHelp := mHelp; result.mType := mType; result.mIVal := mIVal; result.mIVal2 := mIVal2; + result.mIVal3 := mIVal3; + result.mIVal4 := mIVal4; result.mSVal := mSVal; if (mRVal <> nil) then begin if (result.mRVal = nil) then result.mRVal := TDynRecList.Create(mRVal.count); - if (result.mRHash = nil) then result.mRHash := hashNewStrInt(); + if (result.mRHash = nil) then result.mRHash := THashStrInt.Create(); for rec in mRVal do result.addListItem(rec.clone(registerIn)); end; result.mRecRef := mRecRef; @@ -651,6 +718,8 @@ begin result.mDefSVal := mDefSVal; result.mDefIVal := mDefIVal; result.mDefIVal2 := mDefIVal2; + result.mDefIVal3 := mDefIVal3; + result.mDefIVal4 := mDefIVal4; result.mDefRecRef := mDefRecRef; result.mEBS := mEBS; result.mEBSTypeName := mEBSTypeName; @@ -725,6 +794,7 @@ begin TType.TString: result := mSVal; TType.TPoint: raise TDynRecException.Create('cannot convert point field to variant'); TType.TSize: raise TDynRecException.Create('cannot convert size field to variant'); + TType.TColor: raise TDynRecException.Create('cannot convert color field to variant'); TType.TList: raise TDynRecException.Create('cannot convert list field to variant'); TType.TTrigData: raise TDynRecException.Create('cannot convert trigdata field to variant'); else result := Unassigned; raise TDynRecException.Create('ketmar forgot to handle some field type'); @@ -840,6 +910,8 @@ begin TType.TPoint, TType.TSize: result := ((mIVal = fld.mIVal) and (mIVal2 = fld.mIVal2)); + TType.TColor: + result := ((mIVal = fld.mIVal) and (mIVal2 = fld.mIVal2) and (mIVal3 = fld.mIVal3) and (mIVal4 = fld.mIVal4)); TType.TList: result := false; TType.TTrigData: begin @@ -864,11 +936,24 @@ begin end; +function TDynField.getRed (): Integer; inline; begin result := mIVal; if (result < 0) then result := 0 else if (result > 255) then result := 255; end; +procedure TDynField.setRed (v: Integer); inline; begin if (v < 0) then v := 0 else if (v > 255) then v := 255; mIVal := v; end; + +function TDynField.getGreen (): Integer; inline; begin result := mIVal2; if (result < 0) then result := 0 else if (result > 255) then result := 255; end; +procedure TDynField.setGreen (v: Integer); inline; begin if (v < 0) then v := 0 else if (v > 255) then v := 255; mIVal2 := v; end; + +function TDynField.getBlue (): Integer; inline; begin result := mIVal3; if (result < 0) then result := 0 else if (result > 255) then result := 255; end; +procedure TDynField.setBlue (v: Integer); inline; begin if (v < 0) then v := 0 else if (v > 255) then v := 255; mIVal3 := v; end; + +function TDynField.getAlpha (): Integer; inline; begin result := mIVal4; if (result < 0) then result := 0 else if (result > 255) then result := 255; end; +procedure TDynField.setAlpha (v: Integer); inline; begin if (v < 0) then v := 0 else if (v > 255) then v := 255; mIVal4 := v; end; + + procedure TDynField.parseDefaultValue (); var stp: TTextParser = nil; oSVal: AnsiString; - oIVal, oIVal2: Integer; + oIVal, oIVal2, oIVal3, oIVal4: Integer; oRRef: TDynRecord; oDef: Boolean; begin @@ -877,6 +962,8 @@ begin mDefSVal := ''; mDefIVal := 0; mDefIVal2 := 0; + mDefIVal3 := 0; + mDefIVal4 := 0; // default value for alpha mDefRecRef := nil; end else @@ -884,19 +971,26 @@ begin oSVal := mSVal; oIVal := mIVal; oIVal2 := mIVal2; + oIVal3 := mIVal3; + oIVal4 := mIVal4; oRRef := mRecRef; oDef := mDefined; try stp := TStrTextParser.Create(mDefUnparsed+';'); parseValue(stp); + //if (mType = TType.TColor) then writeln('4=[', mIVal4, ']'); mDefSVal := mSVal; mDefIVal := mIVal; mDefIVal2 := mIVal2; + mDefIVal3 := mIVal3; + mDefIVal4 := mIVal4; mDefRecRef := mRecRef; finally mSVal := oSVal; mIVal := oIVal; mIVal2 := oIVal2; + mIVal3 := oIVal3; + mIVal4 := oIVal4; mRecRef := oRRef; mDefined := oDef; stp.Free(); @@ -912,12 +1006,15 @@ begin if not mHasDefault then begin if mInternal then exit; - raise TDynRecException.CreateFmt('field ''%s'' in record ''%s'' of record type ''%s'' is not set', [mName, mOwner.mId, mOwner.mName]); + raise TDynRecException.CreateFmt('field ''%s'' in record ''%s'' of record type ''%s'' is not set', [mName, mOwner.mId, mOwner.mTypeName]); end; if (mEBS = TEBS.TRec) then mRecRef := mDefRecRef; mSVal := mDefSVal; mIVal := mDefIVal; mIVal2 := mDefIVal2; + mIVal3 := mDefIVal3; + mIVal4 := mDefIVal4; + //if (mType = TType.TColor) then writeln('4=[', mDefIVal4, ']'); mDefined := true; end; @@ -930,6 +1027,7 @@ begin case mType of TType.TChar, TType.TString: result := (mSVal = mDefSVal); TType.TPoint, TType.TSize: result := (mIVal = mDefIVal2) and (mIVal2 = mDefIVal2); + TType.TColor: result := (mIVal = mDefIVal2) and (mIVal2 = mDefIVal2) and (mIVal3 = mDefIVal3) and (mIVal4 = mDefIVal4); TType.TList, TType.TTrigData: result := false; // no default values for those types else result := (mIVal = mDefIVal); end; @@ -967,6 +1065,26 @@ begin end; +function TDynField.removeListItem (const aid: AnsiString): TDynRecord; +var + f, idx: Integer; +begin + result := nil; + if mRHash.get(aid, idx) then + begin + assert((idx >= 0) and (idx < mRVal.count)); + result := mRVal[idx]; + // fix hash and list + for f := idx+1 to mRVal.count-1 do + begin + if (Length(mRVal[f].mId) > 0) then mRHash.put(mRVal[f].mId, f-1); + end; + mRHash.del(aid); + mRVal.delete(idx); + end; +end; + + class function TDynField.getTypeName (t: TType): AnsiString; begin case t of @@ -981,6 +1099,7 @@ begin TType.TString: result := 'string'; TType.TPoint: result := 'point'; TType.TSize: result := 'size'; + TType.TColor: result := 'color'; TType.TList: result := 'array'; TType.TTrigData: result := 'trigdata'; else raise TDynRecException.Create('ketmar forgot to handle some field type'); @@ -1023,7 +1142,7 @@ var ainternal: Boolean; writedef: Boolean; defstr: AnsiString; - defint, defint2: Integer; + defint, defint2, defint3, defint4: Integer; hasdefStr: Boolean; hasdefInt: Boolean; hasdefId: Boolean; @@ -1033,6 +1152,7 @@ var asmonid: Boolean; defech: AnsiChar; xalias: AnsiString; + atip, ahelp: AnsiString; begin fldname := ''; fldtype := ''; @@ -1046,6 +1166,8 @@ begin defstr := ''; defint := 0; defint2 := 0; + defint3 := 0; + defint4 := 0; hasdefStr := false; hasdefInt := false; hasdefId := false; @@ -1054,11 +1176,13 @@ begin lmaxdim := -1; lebs := TDynField.TEBS.TNone; xalias := ''; + atip := ''; + ahelp := ''; // field name - fldname := pr.expectStrOrId(); + fldname := pr.expectIdOrStr(); - while (pr.tokType <> pr.TTSemi) do + while (not pr.isDelim(';')) do begin if pr.eatId('type') then begin @@ -1083,6 +1207,20 @@ begin continue; end; + if pr.eatId('tip') then + begin + if (Length(atip) > 0) then raise TDynParseException.CreateFmt(pr, 'duplicate tip definition for field ''%s''', [fldname]); + atip := pr.expectStr(false); + continue; + end; + + if pr.eatId('help') then + begin + if (Length(ahelp) > 0) then raise TDynParseException.CreateFmt(pr, 'duplicate tip definition for field ''%s''', [fldname]); + ahelp := pr.expectStr(false); + continue; + end; + if pr.eatId('offset') then begin if (fldofs >= 0) then raise TDynParseException.CreateFmt(pr, 'duplicate field ''%s'' offset', [fldname]); @@ -1144,6 +1282,11 @@ begin if pr.eatDelim('[') then defech := ']' else begin pr.expectDelim('('); defech := ')'; end; defint := pr.expectInt(); defint2 := pr.expectInt(); + if (pr.tokType = pr.TTInt) then + begin + defint3 := pr.expectInt(); + if (pr.tokType = pr.TTInt) then defint4 := pr.expectInt(); + end; pr.expectDelim(defech); end; else @@ -1172,7 +1315,7 @@ begin lebs := TDynField.TEBS.TRec; end; - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); // create field mName := fldname; @@ -1188,6 +1331,7 @@ begin else if (fldtype = 'string') then mType := TType.TString else if (fldtype = 'point') then mType := TType.TPoint else if (fldtype = 'size') then mType := TType.TSize + else if (fldtype = 'color') then mType := TType.TColor else if (fldtype = 'trigdata') then mType := TType.TTrigData else begin @@ -1230,6 +1374,7 @@ begin begin if (mType = TType.TPoint) then self.mDefUnparsed := Format('(%d %d)', [defint, defint2]) else if (mType = TType.TSize) then self.mDefUnparsed := Format('[%d %d]', [defint, defint2]) + else if (mType = TType.TColor) then self.mDefUnparsed := Format('(%d %d %d %d)', [defint, defint2, defint3, defint4]) else self.mDefUnparsed := Format('%d', [defint]); end; @@ -1245,6 +1390,8 @@ begin self.mWriteDef := writedef; self.mInternal := ainternal; self.mAlias := xalias; + self.mTip := atip; + self.mHelp := ahelp; end; @@ -1255,7 +1402,7 @@ begin end; -procedure TDynField.writeBinTo (st: TStream); +procedure TDynField.writeBinTo (var hasLostData: Boolean; st: TStream); var s: AnsiString; f: Integer; @@ -1282,7 +1429,7 @@ begin if (mRecRef <> nil) then begin ws := TSFSMemoryChunkStream.Create(buf, mMaxDim); - mRecRef.writeBinTo(ws, mMaxDim); // as trigdata + mRecRef.writeBinTo(hasLostData, ws, mMaxDim); // as trigdata end; st.WriteBuffer(buf^, mMaxDim); finally @@ -1396,16 +1543,20 @@ begin writeInt(st, Word(mIVal2)); exit; end; - TType.TList: + TType.TColor: begin - assert(false); + if (mMaxDim >= 0) then raise TDynRecException.CreateFmt('color array in field ''%s'' cannot be written', [mName]); + writeInt(st, Byte(mIVal)); + writeInt(st, Byte(mIVal2)); + writeInt(st, Byte(mIVal3)); + //writeInt(st, Byte(mIVal4)); // the only place we have RGB in binary map is effect trigger, and it has no alpha + if (mIVal4 <> 255) then hasLostData := true; exit; end; + TType.TList: + raise TDynRecException.Create('cannot write lists to binary format'); TType.TTrigData: - begin - assert(false); - exit; - end; + raise TDynRecException.Create('cannot write triggers to binary format (internal error)'); else raise TDynRecException.Create('ketmar forgot to handle some field type'); end; end; @@ -1489,7 +1640,7 @@ begin begin if (es.mVals[f] = mask) then begin - if not first then wr.put('+') else first := false; + if not first then wr.put(' | ') else first := false; wr.put(es.mIds[f]); found := true; break; @@ -1540,6 +1691,12 @@ begin wr.put('(%d %d);'#10, [mIVal, mIVal2]); exit; end; + TType.TColor: + begin + if (mIVal3 = 255) then wr.put('(%d %d %d);'#10, [mIVal, mIVal2, mIVal3]) + else wr.put('(%d %d %d %d);'#10, [mIVal, mIVal2, mIVal3, mIVal4]); + exit; + end; TType.TList: begin assert(false); @@ -1576,9 +1733,9 @@ begin rec := mOwner; // find trigger definition tfld := rec.trigTypeField(); - if (tfld = nil) then raise TDynRecException.CreateFmt('triggerdata value for field ''%s'' in record ''%s'' without TriggerType field', [mName, rec.mName]); + if (tfld = nil) then raise TDynRecException.CreateFmt('triggerdata value for field ''%s'' in record ''%s'' without TriggerType field', [mName, rec.mTypeName]); rc := mOwner.mOwner.trigTypeFor[tfld.mSVal]; // find in mapdef - if (rc = nil) then raise TDynRecException.CreateFmt('triggerdata definition for field ''%s'' in record ''%s'' with type ''%s'' not found', [mName, rec.mName, tfld.mSVal]); + if (rc = nil) then raise TDynRecException.CreateFmt('triggerdata definition for field ''%s'' in record ''%s'' with type ''%s'' not found', [mName, rec.mTypeName, tfld.mSVal]); rc := rc.clone(mOwner.mHeaderRec); rc.mHeaderRec := mOwner.mHeaderRec; // on error, it will be freed by memowner @@ -1722,6 +1879,16 @@ begin mDefined := true; exit; end; + TType.TColor: + begin + mIVal := readByte(st); + mIVal2 := readByte(st); + mIVal3 := readByte(st); + //mIVal4 := readByte(st); // the only place we have RGB in binary map is effect trigger, and it has no alpha + mIVal4 := 255; + mDefined := true; + exit; + end; TType.TList: begin assert(false); @@ -1755,7 +1922,7 @@ var edim: AnsiChar; begin if (pr.tokType = pr.TTEOF) then raise TDynParseException.Create(pr, 'field value expected'); - if (pr.tokType = pr.TTSemi) then raise TDynParseException.Create(pr, 'extra semicolon'); + if (pr.isDelim(';')) then raise TDynParseException.Create(pr, 'extra semicolon'); // if this field should contain struct, convert type and parse struct case mEBS of TEBS.TNone: begin end; @@ -1764,21 +1931,20 @@ begin // ugly hack. sorry. if (mType = TType.TTrigData) then begin - pr.expectTT(pr.TTBegin); - if (pr.tokType = pr.TTEnd) then + pr.expectDelim('{'); + if (pr.eatDelim('}')) then begin // '{}' mRecRef := nil; - pr.expectTT(pr.TTEnd); end else begin rec := mOwner; // find trigger definition tfld := rec.trigTypeField(); - if (tfld = nil) then raise TDynParseException.CreateFmt(pr, 'triggerdata value for field ''%s'' in record ''%s'' without ''type'' field', [mName, rec.mName]); + if (tfld = nil) then raise TDynParseException.CreateFmt(pr, 'triggerdata value for field ''%s'' in record ''%s'' without ''type'' field', [mName, rec.mTypeName]); rc := mOwner.mOwner.trigTypeFor[tfld.mSVal]; // find in mapdef - if (rc = nil) then raise TDynParseException.CreateFmt(pr, 'triggerdata definition for field ''%s'' in record ''%s'' with type ''%s'' not found', [mName, rec.mName, tfld.mSVal]); + if (rc = nil) then raise TDynParseException.CreateFmt(pr, 'triggerdata definition for field ''%s'' in record ''%s'' with type ''%s'' not found', [mName, rec.mTypeName, tfld.mSVal]); rc := rc.clone(mOwner.mHeaderRec); rc.mHeaderRec := mOwner.mHeaderRec; //writeln(rc.definition); @@ -1787,7 +1953,7 @@ begin mRecRef := rc; end; mDefined := true; - pr.eatTT(pr.TTSemi); // hack: allow (but don't require) semicolon after inline records + pr.eatDelim(';'); // hack: allow (but don't require) semicolon after inline records exit; end; // other record types @@ -1812,10 +1978,10 @@ begin pr.expectId(); end; mDefined := true; - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); exit; end - else if (pr.tokType = pr.TTBegin) then + else if (pr.isDelim('{')) then begin //rec := mOwner.mOwner.recType[mEBSTypeName]; // find in mapdef rec := nil; @@ -1828,12 +1994,12 @@ begin mDefined := true; if mOwner.addRecordByType(mEBSTypeName, rc) then begin - raise TDynParseException.CreateFmt(pr, 'duplicate record with id ''%s'' for field ''%s'' in record ''%s''', [rc.mId, mName, mOwner.mName]); + raise TDynParseException.CreateFmt(pr, 'duplicate record with id ''%s'' for field ''%s'' in record ''%s''', [rc.mId, mName, mOwner.mTypeName]); end; - pr.eatTT(pr.TTSemi); // hack: allow (but don't require) semicolon after inline records + pr.eatDelim(';'); // hack: allow (but don't require) semicolon after inline records exit; end; - pr.expectTT(pr.TTBegin); + pr.expectDelim('{'); end; TEBS.TEnum: begin @@ -1847,7 +2013,7 @@ begin mSVal := tk; //writeln('ENUM ', mEBSName, '; element <', mSVal, '> with value ', mIVal); mDefined := true; - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); exit; end; TEBS.TBitSet: @@ -1868,7 +2034,7 @@ begin pr.skipToken(); // plus or pipe end; mDefined := true; - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); exit; end; else raise TDynParseException.Create(pr, 'ketmar forgot to handle some EBS type'); @@ -1881,7 +2047,7 @@ begin else if pr.eatId('false') or pr.eatId('ona') or pr.eatId('no') then mIVal := 0 else raise TDynParseException.CreateFmt(pr, 'invalid bool value for field ''%s''', [mName]); mDefined := true; - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); exit; end; TType.TChar: @@ -1901,50 +2067,50 @@ begin if (Length(mSVal) > mMaxDim) then raise TDynParseException.CreateFmt(pr, 'invalid string size for field ''%s''', [mName]); end; mDefined := true; - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); exit; end; TType.TByte: begin parseInt(-128, 127); - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); exit; end; TType.TUByte: begin parseInt(0, 255); - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); exit; end; TType.TShort: begin parseInt(-32768, 32768); - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); exit; end; TType.TUShort: begin parseInt(0, 65535); - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); exit; end; TType.TInt: begin parseInt(Integer($80000000), $7fffffff); - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); exit; end; TType.TUInt: begin parseInt(0, $7fffffff); //FIXME - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); exit; end; TType.TString: begin mSVal := pr.expectStr(true); mDefined := true; - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); exit; end; TType.TPoint, @@ -1954,16 +2120,39 @@ begin mIVal := pr.expectInt(); if (mType = TType.TSize) then begin - if (mIVal < 0) or (mIVal > 32767) then raise TDynParseException.CreateFmt(pr, 'invalid %s value for field ''%s''', [getTypeName(mType), mName]); + if (mIVal < 0) or (mIVal > 65535) then raise TDynParseException.CreateFmt(pr, 'invalid %s value for field ''%s''', [getTypeName(mType), mName]); end; mIVal2 := pr.expectInt(); if (mType = TType.TSize) then begin - if (mIVal2 < 0) or (mIVal2 > 32767) then raise TDynParseException.CreateFmt(pr, 'invalid %s value for field ''%s''', [getTypeName(mType), mName]); + if (mIVal2 < 0) or (mIVal2 > 65535) then raise TDynParseException.CreateFmt(pr, 'invalid %s value for field ''%s''', [getTypeName(mType), mName]); end; mDefined := true; pr.expectDelim(edim); - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); + exit; + end; + TType.TColor: + begin + if pr.eatDelim('[') then edim := ']' else begin pr.expectDelim('('); edim := ')'; end; + mIVal := pr.expectInt(); + if (mIVal < 0) or (mIVal > 255) then raise TDynParseException.CreateFmt(pr, 'invalid %s value for field ''%s''', [getTypeName(mType), mName]); + mIVal2 := pr.expectInt(); + if (mIVal2 < 0) or (mIVal2 > 255) then raise TDynParseException.CreateFmt(pr, 'invalid %s value for field ''%s''', [getTypeName(mType), mName]); + mIVal3 := pr.expectInt(); + if (mIVal3 < 0) or (mIVal3 > 255) then raise TDynParseException.CreateFmt(pr, 'invalid %s value for field ''%s''', [getTypeName(mType), mName]); + if (pr.tokType = pr.TTInt) then + begin + mIVal4 := pr.expectInt(); + if (mIVal4 < 0) or (mIVal4 > 255) then raise TDynParseException.CreateFmt(pr, 'invalid %s value for field ''%s''', [getTypeName(mType), mName]); + end + else + begin + mIVal4 := 255; + end; + mDefined := true; + pr.expectDelim(edim); + pr.expectDelim(';'); exit; end; TType.TList: @@ -1987,7 +2176,7 @@ constructor TDynRecord.Create (pr: TTextParser); begin if (pr = nil) then raise TDynParseException.Create(pr, 'cannot create record type without type definition'); mId := ''; - mName := ''; + mTypeName := ''; mSize := 0; mFields := TDynFieldList.Create(); {$IF DEFINED(XDYNREC_USE_FIELDHASH)} @@ -2005,7 +2194,7 @@ end; constructor TDynRecord.Create (); begin - mName := ''; + mTypeName := ''; mSize := 0; mFields := TDynFieldList.Create(); {$IF DEFINED(XDYNREC_USE_FIELDHASH)} @@ -2038,7 +2227,7 @@ begin mRec2Free.Free(); mRec2Free := nil; end; - mName := ''; + mTypeName := ''; for fld in mFields do fld.Free(); mFields.Free(); mFields := nil; @@ -2167,7 +2356,9 @@ begin result := TDynRecord.Create(); result.mOwner := mOwner; result.mId := mId; - result.mName := mName; + result.mTypeName := mTypeName; + result.mTip := mTip; + result.mHelp := mHelp; result.mSize := mSize; result.mHeader := mHeader; result.mBinBlock := mBinBlock; @@ -2245,7 +2436,7 @@ begin if (fld.mRVal = nil) then begin fld.mRVal := TDynRecList.Create(); - fld.mRHash := hashNewStrInt(); + fld.mRHash := THashStrInt.Create(); end; result := fld.addListItem(rc); end; @@ -2278,7 +2469,7 @@ begin if not (fld.mEBSType is TDynEBS) then continue; es := (fld.mEBSType as TDynEBS); assert(es <> nil); - if StrEqu(es.mName, 'TriggerType') then begin result := fld; exit; end; + if StrEqu(es.mTypeName, 'TriggerType') then begin result := fld; exit; end; end; result := nil; end; @@ -2298,14 +2489,67 @@ end; function TDynRecord.newTypedRecord (const atypename, aid: AnsiString): TDynRecord; var trc: TDynRecord; + fld: TDynField; begin if not mHeader then raise TDynRecException.Create('cannot create new records with non-header'); + if (Length(aid) = 0) then raise TDynRecException.CreateFmt('cannot create new record of type ''%s'' without id', [atypename]); trc := mapdef.recType[atypename]; if (trc = nil) then begin result := nil; exit; end; + // check if aid is unique + fld := field[atypename]; + if (fld <> nil) and (fld.getListItem(aid) <> nil) then raise TDynRecException.CreateFmt('cannot create record of type ''%s'' with duplicate id ''%s''', [atypename, aid]); result := trc.clone(self); - result.mId := ''; // for now - addRecordByType(atypename, result); result.mId := aid; + addRecordByType(atypename, result); +end; + + +procedure TDynRecord.clearRefRecs (rec: TDynRecord); + procedure clearRefs (fld: TDynField); + var + rc: TDynRecord; + begin + if (fld = nil) then exit; + if (fld.mRecRef = rec) then fld.mRecRef := nil; + if (fld.mType = fld.TType.TList) then for rc in fld.mRVal do rc.clearRefRecs(rec); + end; +var + fld: TDynField; +begin + if (rec = nil) or (mFields = nil) then exit; + for fld in mFields do clearRefs(fld); +end; + + +// remove record with the given type and id +// return `true` if record was successfully found and removed +// this will do all necessary recref cleanup too +function TDynRecord.removeTypedRecord (const atypename, aid: AnsiString): Boolean; +var + trc, rec: TDynRecord; + fld: TDynField; + f: Integer; + doFree: Boolean = false; +begin + result := false; + if not mHeader then raise TDynRecException.Create('cannot remove records with non-header'); + if (Length(aid) = 0) then exit; + trc := mapdef.recType[atypename]; + if (trc = nil) then exit; + fld := field[atypename]; + if (fld = nil) then exit; + rec := fld.removeListItem(aid); + if (rec = nil) then exit; + clearRefRecs(rec); + for f := 0 to mRec2Free.count-1 do + begin + if (mRec2Free[f] = rec) then + begin + mRec2Free[f] := nil; + doFree := true; + end; + end; + if doFree then rec.Free(); end; @@ -2350,10 +2594,10 @@ begin begin while true do begin - while pr.eatTT(pr.TTComma) do begin end; + while (pr.eatDelim(',')) do begin end; if pr.eatDelim(')') then break; tdn := pr.expectId(); - if isForTrig[tdn] then raise TDynParseException.CreateFmt(pr, 'duplicate trigdata ''%s'' trigtype ''%s''', [mName, tdn]); + if isForTrig[tdn] then raise TDynParseException.CreateFmt(pr, 'duplicate trigdata ''%s'' trigtype ''%s''', [mTypeName, tdn]); SetLength(mTrigTypes, Length(mTrigTypes)+1); mTrigTypes[High(mTrigTypes)] := tdn; end; @@ -2364,35 +2608,47 @@ begin SetLength(mTrigTypes, 1); mTrigTypes[0] := tdn; end; - mName := 'TriggerData'; + mTypeName := 'TriggerData'; end else begin - mName := pr.expectStrOrId(); - while (pr.tokType <> pr.TTBegin) do + mTypeName := pr.expectIdOrStr(); + while (not pr.isDelim('{')) do begin if pr.eatId('header') then begin mHeader := true; continue; end; if pr.eatId('size') then begin - if (mSize > 0) then raise TDynParseException.CreateFmt(pr, 'duplicate `size` in record ''%s''', [mName]); + if (mSize > 0) then raise TDynParseException.CreateFmt(pr, 'duplicate `size` in record ''%s''', [mTypeName]); mSize := pr.expectInt(); - if (mSize < 1) then raise TDynParseException.CreateFmt(pr, 'invalid record ''%s'' size: %d', [mName, mSize]); + if (mSize < 1) then raise TDynParseException.CreateFmt(pr, 'invalid record ''%s'' size: %d', [mTypeName, mSize]); pr.expectId('bytes'); continue; end; if pr.eatId('binblock') then begin - if (mBinBlock >= 0) then raise TDynParseException.CreateFmt(pr, 'duplicate `binblock` in record ''%s''', [mName]); + if (mBinBlock >= 0) then raise TDynParseException.CreateFmt(pr, 'duplicate `binblock` in record ''%s''', [mTypeName]); mBinBlock := pr.expectInt(); - if (mBinBlock < 1) then raise TDynParseException.CreateFmt(pr, 'invalid record ''%s'' binblock: %d', [mName, mBinBlock]); + if (mBinBlock < 1) then raise TDynParseException.CreateFmt(pr, 'invalid record ''%s'' binblock: %d', [mTypeName, mBinBlock]); + continue; + end; + if pr.eatId('tip') then + begin + if (Length(mTip) > 0) then raise TDynParseException.CreateFmt(pr, 'duplicate tip definition for record ''%s''', [mTypeName]); + mTip := pr.expectStr(false); + continue; + end; + if pr.eatId('help') then + begin + if (Length(mHelp) > 0) then raise TDynParseException.CreateFmt(pr, 'duplicate help definition for record ''%s''', [mTypeName]); + mHelp := pr.expectStr(false); continue; end; end; end; - pr.expectTT(pr.TTBegin); + pr.expectDelim('{'); // load fields - while (pr.tokType <> pr.TTEnd) do + while (not pr.isDelim('}')) do begin fld := TDynField.Create(pr); // append @@ -2404,7 +2660,7 @@ begin end; // done with field end; - pr.expectTT(pr.TTEnd); + pr.expectDelim('}'); end; @@ -2434,7 +2690,7 @@ begin else begin // record - result := quoteStr(mName); + result := quoteStr(mTypeName); if (mSize >= 0) then result += Format(' size %d bytes', [mSize]); if mHeader then result += ' header'; end; @@ -2479,7 +2735,10 @@ var rt := findRecordByTypeId(fld.mEBSTypeName, fld.mRecRefId); if (rt = nil) then begin - e_LogWritefln('record of type ''%s'' with id ''%s'' links to inexistant record of type ''%s'' with id ''%s''', [rec.mName, rec.mId, fld.mEBSTypeName, fld.mRecRefId], MSG_WARNING); + if assigned(DynWarningCB) then + begin + DynWarningCB(formatstrf('record of type ''%s'' with id ''%s'' links to inexistant record of type ''%s'' with id ''%s''', [rec.mTypeName, rec.mId, fld.mEBSTypeName, fld.mRecRefId]), -1, -1); + end; //raise TDynRecException.CreateFmt('record of type ''%s'' with id ''%s'' links to inexistant record of type ''%s'' with id ''%s''', [rec.mName, rec.mId, fld.mEBSTypeName, fld.mRecRefId]); end; //writeln(' ', rec.mName, '.', rec.mId, ':', fld.mName, ' -> ', rt.mName, '.', rt.mId, ' (', fld.mEBSTypeName, '.', fld.mRecRefId, ')'); @@ -2489,7 +2748,7 @@ var end; for fld in rec.mFields do begin - //writeln(' ', fld.mName); + //if (fld.mName = 'ambient_color') then writeln('****', fld.mName); fld.fixDefaultValue(); // just in case end; end; @@ -2533,7 +2792,7 @@ begin else begin // create list for this type - fld := TDynField.Create(rec.mName, TDynField.TType.TList); + fld := TDynField.Create(rec.mTypeName, TDynField.TType.TList); fld.mOwner := self; addField(fld); if (bsize > 0) then @@ -2546,7 +2805,7 @@ begin rec := rect.clone(self); rec.mHeaderRec := self; rec.parseBinValue(mst); - rec.mId := Format('%s%d', [rec.mName, f]); + rec.mId := Format('%s%d', [rec.mTypeName, f]); fld.addListItem(rec); //writeln('parsed ''', rec.mId, '''...'); end; @@ -2566,8 +2825,8 @@ begin end; // read fields - if StrEqu(mName, 'TriggerData') then mSize := Integer(st.size-st.position); - if (mSize < 1) then raise TDynRecException.CreateFmt('cannot read record of type ''%s'' with unknown size', [mName]); + if StrEqu(mTypeName, 'TriggerData') then mSize := Integer(st.size-st.position); + if (mSize < 1) then raise TDynRecException.CreateFmt('cannot read record of type ''%s'' with unknown size', [mTypeName]); GetMem(buf, mSize); st.ReadBuffer(buf^, mSize); for fld in mFields do @@ -2579,6 +2838,12 @@ begin //writeln('parsing ''', mName, '.', fld.mName, '''...'); fld.parseBinValue(mst); end; + // fix default values + for fld in mFields do + begin + if (fld.mType = TDynField.TType.TList) then continue; + fld.fixDefaultValue(); + end; finally mst.Free(); if (buf <> nil) then FreeMem(buf); @@ -2586,14 +2851,13 @@ begin end; -procedure TDynRecord.writeBinTo (st: TStream; trigbufsz: Integer=-1; onlyFields: Boolean=false); +procedure TDynRecord.writeBinTo (var hasLostData: Boolean; st: TStream; trigbufsz: Integer=-1; onlyFields: Boolean=false); var fld: TDynField; rec, rv: TDynRecord; buf: PByte = nil; ws: TStream = nil; blk, blkmax: Integer; - //f, c: Integer; bufsz: Integer = 0; blksz: Integer; begin @@ -2618,11 +2882,15 @@ begin // record list? if (fld.mType = fld.TType.TList) then continue; // later if fld.mInternal then continue; - if (fld.mBinOfs < 0) then continue; + if (fld.mBinOfs < 0) then + begin + if not fld.equToDefault then hasLostData := true; + continue; + end; if (fld.mBinOfs >= bufsz) then raise TDynRecException.Create('binary value offset is outside of the buffer'); TSFSMemoryChunkStream(ws).setup(buf+fld.mBinOfs, bufsz-fld.mBinOfs); //writeln('writing field <', fld.mName, '>'); - fld.writeBinTo(ws); + fld.writeBinTo(hasLostData, ws); end; // write block with normal fields @@ -2672,7 +2940,7 @@ begin if (rec = nil) then continue; if (rec.mBinBlock <> blk) then continue; if (ws = nil) then ws := TMemoryStream.Create(); - for rv in fld.mRVal do rv.writeBinTo(ws); + for rv in fld.mRVal do rv.writeBinTo(hasLostData, ws); end; end; // flush block @@ -2704,10 +2972,12 @@ procedure TDynRecord.writeTo (wr: TTextWriter; putHeader: Boolean=true); var fld: TDynField; rec: TDynRecord; + putTypeComment: Boolean; + f: Integer; begin if putHeader then begin - wr.put(mName); + wr.put(mTypeName); if (Length(mId) > 0) then begin wr.put(' '); wr.put(mId); end; wr.put(' '); end; @@ -2720,11 +2990,31 @@ begin if (fld.mType = fld.TType.TList) then begin if not mHeader then raise TDynRecException.Create('record list in non-header record'); - if (fld.mRVal <> nil) then + if (fld.mRVal <> nil) and (fld.mRVal.count > 0) then begin + putTypeComment := true; for rec in fld.mRVal do begin - if (Length(rec.mId) = 0) then continue; + if (rec = nil) or (Length(rec.mId) = 0) then continue; + if putTypeComment then + begin + wr.put(#10); + if (80-wr.curIndent*2 >= 2) then + begin + wr.putIndent(); + for f := wr.curIndent to 80-wr.curIndent do wr.put('/'); + wr.put(#10); + end; + putTypeComment := false; + wr.putIndent(); + wr.put('// '); + wr.put(fld.name); + wr.put(#10); + end + else + begin + wr.put(#10); + end; wr.putIndent(); rec.writeTo(wr, true); end; @@ -2782,14 +3072,19 @@ var procedure linkNames (rec: TDynRecord); var fld: TDynField; - rt: TDynRecord; + rt, rvc: TDynRecord; begin + if (rec = nil) then exit; //writeln('*** rec: ', rec.mName, '.', rec.mId, ' (', rec.mFields.count, ')'); for fld in rec.mFields do begin + if (fld.mType = TDynField.TType.TList) then + begin + for rvc in fld.mRVal do linkNames(rvc); + end; if (fld.mType = TDynField.TType.TTrigData) then begin - if (fld.mRecRef <> nil) then linkNames(fld.mRecRef); + //if (fld.mRecRef <> nil) then linkNames(fld.mRecRef); continue; end; if (Length(fld.mRecRefId) = 0) then continue; @@ -2798,7 +3093,7 @@ var if (rt = nil) then begin //e_LogWritefln('record of type ''%s'' with id ''%s'' links to inexistant record of type ''%s'' with id ''%s''', [rec.mName, rec.mId, fld.mEBSTypeName, fld.mRecRefId], MSG_WARNING); - raise TDynParseException.CreateFmt(pr, 'record of type ''%s'' with id ''%s'' links to inexistant record of type ''%s'' with id ''%s''', [rec.mName, rec.mId, fld.mEBSTypeName, fld.mRecRefId]); + raise TDynParseException.CreateFmt(pr, 'record of type ''%s'' with id ''%s'' links to inexistant record of type ''%s'' with id ''%s''', [rec.mTypeName, rec.mId, fld.mEBSTypeName, fld.mRecRefId]); end; //writeln(' ', rec.mName, '.', rec.mId, ':', fld.mName, ' -> ', rt.mName, '.', rt.mId, ' (', fld.mEBSTypeName, '.', fld.mRecRefId, ')'); fld.mRecRefId := ''; @@ -2808,14 +3103,14 @@ var for fld in rec.mFields do begin //writeln(' ', fld.mName); - fld.fixDefaultValue(); // just in case + fld.fixDefaultValue(); end; end; begin - if (mOwner = nil) then raise TDynParseException.CreateFmt(pr, 'can''t parse record ''%s'' value without owner', [mName]); + if (mOwner = nil) then raise TDynParseException.CreateFmt(pr, 'can''t parse record ''%s'' value without owner', [mTypeName]); - {$IF DEFINED(D2D_DYNREC_PROFILER)}stall := curTimeMicro();{$ENDIF} + {$IF DEFINED(D2D_DYNREC_PROFILER)}stall := getTimeMicro();{$ENDIF} // not a header? if not mHeader then @@ -2829,8 +3124,8 @@ begin end; //writeln('parsing record <', mName, '>'); - if not beginEaten then pr.expectTT(pr.TTBegin); - while (pr.tokType <> pr.TTEnd) do + if not beginEaten then pr.expectDelim('{'); + while (not pr.isDelim('}')) do begin if (pr.tokType <> pr.TTId) then raise TDynParseException.Create(pr, 'identifier expected'); //writeln('<', mName, '.', pr.tokStr, '>'); @@ -2839,66 +3134,58 @@ begin if mHeader then begin // add records with this type (if any) - {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF} + {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := getTimeMicro();{$ENDIF} trc := mOwner.recType[pr.tokStr]; - {$IF DEFINED(D2D_DYNREC_PROFILER)}profFindRecType := curTimeMicro()-stt;{$ENDIF} + {$IF DEFINED(D2D_DYNREC_PROFILER)}profFindRecType := getTimeMicro()-stt;{$ENDIF} if (trc <> nil) then begin - {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF} + {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := getTimeMicro();{$ENDIF} rec := trc.clone(mHeaderRec); - {$IF DEFINED(D2D_DYNREC_PROFILER)}profCloneRec := curTimeMicro()-stt;{$ENDIF} + {$IF DEFINED(D2D_DYNREC_PROFILER)}profCloneRec := getTimeMicro()-stt;{$ENDIF} rec.mHeaderRec := mHeaderRec; // on error, it will be freed by memowner pr.skipToken(); rec.parseValue(pr); - {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF} - addRecordByType(rec.mName, rec); - {$IF DEFINED(D2D_DYNREC_PROFILER)}profAddRecByType := curTimeMicro()-stt;{$ENDIF} + {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := getTimeMicro();{$ENDIF} + addRecordByType(rec.mTypeName, rec); + {$IF DEFINED(D2D_DYNREC_PROFILER)}profAddRecByType := getTimeMicro()-stt;{$ENDIF} continue; end; end; // fields - {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF} + {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := getTimeMicro();{$ENDIF} //writeln('0: <', mName, '.', pr.tokStr, '>'); fld := field[pr.tokStr]; //writeln('1: <', mName, '.', pr.tokStr, '>'); - {$IF DEFINED(D2D_DYNREC_PROFILER)}profFieldSearching := curTimeMicro()-stt;{$ENDIF} + {$IF DEFINED(D2D_DYNREC_PROFILER)}profFieldSearching := getTimeMicro()-stt;{$ENDIF} if (fld <> nil) then begin //writeln('2: <', mName, '.', pr.tokStr, '>'); - if fld.defined then raise TDynParseException.CreateFmt(pr, 'duplicate field ''%s'' in record ''%s''', [fld.mName, mName]); - if fld.internal then raise TDynParseException.CreateFmt(pr, 'internal field ''%s'' in record ''%s''', [fld.mName, mName]); + if fld.defined then raise TDynParseException.CreateFmt(pr, 'duplicate field ''%s'' in record ''%s''', [fld.mName, mTypeName]); + if fld.internal then raise TDynParseException.CreateFmt(pr, 'internal field ''%s'' in record ''%s''', [fld.mName, mTypeName]); pr.skipToken(); // skip field name //writeln('3: <', mName, '.', pr.tokStr, '>:', pr.tokType); - {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF} + {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := getTimeMicro();{$ENDIF} fld.parseValue(pr); - {$IF DEFINED(D2D_DYNREC_PROFILER)}profFieldValParsing := curTimeMicro()-stt;{$ENDIF} + {$IF DEFINED(D2D_DYNREC_PROFILER)}profFieldValParsing := getTimeMicro()-stt;{$ENDIF} continue; end; // something is wrong - raise TDynParseException.CreateFmt(pr, 'unknown field ''%s'' in record ''%s''', [pr.tokStr, mName]); + raise TDynParseException.CreateFmt(pr, 'unknown field ''%s'' in record ''%s''', [pr.tokStr, mTypeName]); end; - pr.expectTT(pr.TTEnd); + pr.expectDelim('}'); if mHeader then begin // link fields - for fld in mFields do - begin - if (fld.mType <> TDynField.TType.TList) then continue; - for rec in fld.mRVal do linkNames(rec); - end; + linkNames(self); + for rec in mRec2Free do if (rec <> nil) then linkNames(rec); end; - - // fix field defaults - {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF} - for fld in mFields do fld.fixDefaultValue(); - {$IF DEFINED(D2D_DYNREC_PROFILER)}profFixDefaults := curTimeMicro()-stt;{$ENDIF} //writeln('done parsing record <', mName, '>'); - //{$IF DEFINED(D2D_DYNREC_PROFILER)}writeln('stall: ', curTimeMicro()-stall);{$ENDIF} - {$IF DEFINED(D2D_DYNREC_PROFILER)}profRecValParse := curTimeMicro()-stall;{$ENDIF} + //{$IF DEFINED(D2D_DYNREC_PROFILER)}writeln('stall: ', getTimeMicro()-stall);{$ENDIF} + {$IF DEFINED(D2D_DYNREC_PROFILER)}profRecValParse := getTimeMicro()-stall;{$ENDIF} end; @@ -2920,7 +3207,9 @@ end; procedure TDynEBS.cleanup (); begin mIsEnum := false; - mName := ''; + mTypeName := ''; + mTip := ''; + mHelp := ''; mIds := nil; mVals := nil; mMaxName := ''; @@ -2960,7 +3249,7 @@ var f, cv: Integer; begin if mIsEnum then result :='enum ' else result := 'bitset '; - result += mName; + result += mTypeName; result += ' {'#10; // fields if mIsEnum then cv := 0 else cv := 1; @@ -2990,7 +3279,7 @@ function TDynEBS.pasdef (): AnsiString; var f: Integer; begin - result := '// '+mName+#10'const'#10; + result := '// '+mTypeName+#10'const'#10; // fields for f := 0 to High(mIds) do begin @@ -3022,18 +3311,34 @@ begin if pr.eatId('enum') then mIsEnum := true else if pr.eatId('bitset') then mIsEnum := false else pr.expectId('enum'); - mName := pr.expectId(); + mTypeName := pr.expectId(); mMaxVal := Integer($80000000); if mIsEnum then cv := 0 else cv := 1; - pr.expectTT(pr.TTBegin); - while (pr.tokType <> pr.TTEnd) do + while (not pr.isDelim('{')) do + begin + if pr.eatId('tip') then + begin + if (Length(mTip) > 0) then raise TDynParseException.CreateFmt(pr, 'duplicate tip definition for enum/bitset ''%s''', [mTypeName]); + mTip := pr.expectStr(false); + continue; + end; + if pr.eatId('help') then + begin + if (Length(mHelp) > 0) then raise TDynParseException.CreateFmt(pr, 'duplicate help definition for enum/bitset ''%s''', [mTypeName]); + mHelp := pr.expectStr(false); + continue; + end; + break; + end; + pr.expectDelim('{'); + while (not pr.isDelim('}')) do begin idname := pr.expectId(); for f := 0 to High(mIds) do begin - if StrEqu(mIds[f], idname) then raise TDynParseException.CreateFmt(pr, 'duplicate field ''%s'' in enum/bitset ''%s''', [idname, mName]); + if StrEqu(mIds[f], idname) then raise TDynParseException.CreateFmt(pr, 'duplicate field ''%s'' in enum/bitset ''%s''', [idname, mTypeName]); end; - if StrEqu(mMaxName, idname) then raise TDynParseException.CreateFmt(pr, 'duplicate field ''%s'' in enum/bitset ''%s''', [idname, mName]); + if StrEqu(mMaxName, idname) then raise TDynParseException.CreateFmt(pr, 'duplicate field ''%s'' in enum/bitset ''%s''', [idname, mTypeName]); skipAdd := false; hasV := false; v := cv; @@ -3042,7 +3347,7 @@ begin begin if pr.eatId('MAX') then begin - if (Length(mMaxName) > 0) then raise TDynParseException.CreateFmt(pr, 'duplicate max field ''%s'' in enum/bitset ''%s''', [idname, mName]); + if (Length(mMaxName) > 0) then raise TDynParseException.CreateFmt(pr, 'duplicate max field ''%s'' in enum/bitset ''%s''', [idname, mTypeName]); mMaxName := idname; skipAdd := true; end @@ -3071,11 +3376,11 @@ begin if mIsEnum then Inc(cv) else cv := cv shl 1; end; end; - if (pr.tokType = pr.TTEnd) then break; - pr.expectTT(pr.TTComma); - while pr.eatTT(pr.TTComma) do begin end; + if (pr.isDelim('}')) then break; + pr.expectDelim(','); + while (pr.eatDelim(',')) do begin end; end; - pr.expectTT(pr.TTEnd); + pr.expectDelim('}'); // add max field if (Length(mMaxName) > 0) then begin @@ -3311,11 +3616,12 @@ end; // WARNING! stream must be seekable -function TDynMapDef.parseMap (st: TStream): TDynRecord; +function TDynMapDef.parseMap (st: TStream; wasBinary: PBoolean=nil): TDynRecord; var sign: packed array[0..3] of AnsiChar; pr: TTextParser; begin + if (wasBinary <> nil) then wasBinary^ := false; st.position := 0; st.ReadBuffer(sign[0], 4); st.position := 0; @@ -3323,6 +3629,7 @@ begin begin if (sign[3] = #1) then begin + if (wasBinary <> nil) then wasBinary^ := true; result := parseBinMap(st); exit; end;