X-Git-Url: http://deadsoftware.ru/gitweb?a=blobdiff_plain;f=src%2Fshared%2Fxdynrec.pas;h=511c82dd0fd2ba8aeafa406cc5ef26e714318148;hb=987c4a835a103345b59937e8e1be8524a6228712;hp=12d7256429d473c5f46061d7a7fe4084d2251f97;hpb=2fa77a7c9667395ef6d4141cde69ff6349bf301e;p=d2df-sdl.git diff --git a/src/shared/xdynrec.pas b/src/shared/xdynrec.pas index 12d7256..511c82d 100644 --- a/src/shared/xdynrec.pas +++ b/src/shared/xdynrec.pas @@ -1,9 +1,8 @@ -(* 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 - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. + * the Free Software Foundation, version 3 of the License ONLY. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -20,10 +19,29 @@ unit xdynrec; interface uses - Classes, + SysUtils, Variants, Classes, + {$IFDEF USE_MEMPOOL}mempool,{$ENDIF} xparser, xstreams, utils, hashtable; +// ////////////////////////////////////////////////////////////////////////// // +type + TDynRecException = class(Exception) + public + constructor Create (const amsg: AnsiString); + constructor CreateFmt (const afmt: AnsiString; const args: array of const); + end; + + TDynParseException = class(TDynRecException) + public + tokLine, tokCol: Integer; + + public + constructor Create (pr: TTextParser; const amsg: AnsiString); + constructor CreateFmt (pr: TTextParser; const afmt: AnsiString; const args: array of const); + end; + + // ////////////////////////////////////////////////////////////////////////// // type TDynMapDef = class; @@ -36,27 +54,30 @@ 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 // TTrigData: array of mMaxDim bytes, but internally a record (mRecRef) - // arrays of chars are pascal shortstrings (with counter in the first byte) + // in binary: arrays of chars are pascal shortstrings (with counter in the first byte) private type TEBS = (TNone, TRec, TEnum, TBitSet); private - mOwner: TDynRecord; - mPasName: AnsiString; - mName: AnsiString; - mType: TType; + 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 @@ -67,7 +88,7 @@ type mAsT: Boolean; // for points and sizes, use separate fields, names starts with `t` mDefined: Boolean; mHasDefault: Boolean; - mOmitDef: Boolean; + mWriteDef: Boolean; mInternal: Boolean; mNegBool: Boolean; mBitSetUnique: Boolean; // bitset can contain only one value @@ -75,7 +96,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 @@ -88,11 +109,12 @@ type mTagInt: Integer; mTagPtr: Pointer; + // for pasgen + mAlias: AnsiString; + private procedure cleanup (); - procedure parseDef (pr: TTextParser); - procedure parseDefaultValue (); // parse `mDefUnparsed` to `mDefSVal`, `mDefIVal`, `mDefIVal2`, `mDefRecRef` procedure fixDefaultValue (); // this will NOT clone `mDefRecRef` function isDefaultValue (): Boolean; @@ -103,89 +125,126 @@ type function getRecRefIndex (): Integer; - procedure setIVal (v: Integer); inline; + function getVar (): Variant; + procedure setVar (val: Variant); + + procedure setRecRef (arec: TDynRecord); + + procedure parseDef (pr: TTextParser); // parse mapdef definition + function definition (): AnsiString; // generate mapdef definition 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 - { - type - TListEnumerator = record - private - mList: TDynRecList; - mCurIdx: Integer; - public - constructor Create (alist: TDynRecList); - function MoveNext (): Boolean; inline; - function getCurrent (): TDynRecord; inline; - property Current: TDynRecord read getCurrent; - end; - } + // get string name for the given type + class function getTypeName (t: TType): AnsiString; public constructor Create (const aname: AnsiString; atype: TType); + constructor Create (const aname: AnsiString; val: Variant); constructor Create (pr: TTextParser); destructor Destroy (); override; - class function getTypeName (t: TType): AnsiString; + // clone this field; register all list records in `registerIn` + // "registration" is required to manage record lifetime; use header record if in doubt + // owner will be set to `newOwner`, if it is not `nil`, or to `owner` + // for lists, cloning will clone all list members + function clone (newOwner: TDynRecord=nil; registerIn: TDynRecord=nil): TDynField; - function definition (): AnsiString; - function pasdef (): AnsiString; + // compare field values (including trigdata) + // WARNING: won't work for lists + function isSimpleEqu (fld: TDynField): Boolean; + + // parse string value to appropriate type and set new field value + procedure setValue (const s: AnsiString); + + // 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 clone (newOwner: TDynRecord=nil): TDynField; + function getAlpha (): Integer; inline; + procedure setAlpha (v: Integer); inline; + public + // text parser and writer procedure parseValue (pr: TTextParser); + procedure writeTo (wr: TTextWriter); + + // binary parser and writer (DO NOT USE!) procedure parseBinValue (st: TStream); + procedure writeBinTo (var hasLostData: Boolean; st: TStream); - procedure writeTo (wr: TTextWriter); - procedure writeBinTo (st: TStream); + public + // the following functions are here only for 'mapgen'! DO NOT USE! + // build "alias name" for pascal code + function palias (firstUp: Boolean=false): AnsiString; - // won't work for lists - function isSimpleEqu (fld: TDynField): Boolean; + public + property owner: TDynRecord read mOwner; + property name: AnsiString read mName; // field name + property baseType: TType read mType; // field type (base for arrays) + property defined: Boolean read mDefined; // was field value set to something by external code? + 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 + property ebs: TEBS read mEBS; // what kind of reference is this? none, enum, bitset, record + property ebstype: TObject read mEBSType; // reference type (nil, TDynRecord, TDynEBS); WARNING: don't modify type! + property ebstypename: AnsiString read mEBSTypeName; // enum/bitset name + property recref: TDynRecord read mRecRef write setRecRef; // referenced record (actual one, you can modify it) + property recrefIndex: Integer read getRecRefIndex; // index of referenced record in header; -1: not found + // for record lists + property count: Integer read getListCount; + property itemAt[idx: Integer]: TDynRecord read getListItem; + property item[const aname: AnsiString]: TDynRecord read getListItem; default; // alas, FPC 3+ lost property overloading feature + // field value as Variant + property value: Variant read getVar write setVar; - procedure setValue (const s: AnsiString); + property tip: AnsiString read mTip; + property help: AnsiString read mHelp; - function GetEnumerator (): TDynRecList.TEnumerator; inline; + 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; + property tagPtr: Pointer read mTagPtr write mTagPtr; public - property pasname: AnsiString read mPasName; - property name: AnsiString read mName; - property baseType: TType read mType; + // the following properties are here only for 'mapgen'! DO NOT USE! property negbool: Boolean read mNegBool; - property defined: Boolean read mDefined write mDefined; - property internal: Boolean read mInternal write mInternal; property hasTPrefix: Boolean read mAsT; property separatePasFields: Boolean read mSepPosSize; property binOfs: Integer read mBinOfs; - property ival: Integer read mIVal write setIVal; - property ival2: Integer read mIVal2; - property sval: AnsiString read mSVal; - property hasDefault: Boolean read mHasDefault; - property defsval: AnsiString read mDefSVal; - property ebs: TEBS read mEBS; - property ebstype: TObject read mEBSType; - property ebstypename: AnsiString read mEBSTypeName; // enum/bitset name - property recref: TDynRecord read mRecRef write mRecRef; //FIXME: writing is a hack! - property recrefIndex: Integer read getRecRefIndex; // search for this record in header; -1: not found - // for lists - property count: Integer read getListCount; - property item[idx: Integer]: TDynRecord read getListItem; - property items[const aname: AnsiString]: TDynRecord read getListItem; default; // alas, FPC 3+ lost property overloading feature - // userdata - property tagInt: Integer read mTagInt write mTagInt; - property tagPtr: Pointer read mTagPtr write mTagPtr; + property equToDefault: Boolean read isDefaultValue; end; - // "value" header record contains TList fields, with name equal to record type - TDynRecord = class + // record, either with actual values, or with type definitions + TDynRecord = class{$IFDEF USE_MEMPOOL}(TPoolObject){$ENDIF} private mOwner: TDynMapDef; mId: AnsiString; - mPasName: AnsiString; - mName: AnsiString; + mTypeName: AnsiString; + mTip: AnsiString; // short tip + mHelp: AnsiString; // long help mSize: Integer; mFields: TDynFieldList; {$IF DEFINED(XDYNREC_USE_FIELDHASH)} @@ -200,8 +259,11 @@ type mTagInt: Integer; mTagPtr: Pointer; + mRec2Free: TDynRecList; + private procedure parseDef (pr: TTextParser); // parse definition + function definition (): AnsiString; function findByName (const aname: AnsiString): Integer; inline; function hasByName (const aname: AnsiString): Boolean; inline; @@ -215,6 +277,13 @@ type function getForTrigCount (): Integer; inline; function getForTrigAt (idx: Integer): AnsiString; inline; + procedure regrec (rec: TDynRecord); + + 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; @@ -228,55 +297,91 @@ type constructor Create (pr: TTextParser); // parse definition destructor Destroy (); override; - function definition (): AnsiString; - function pasdef (): AnsiString; - - function clone (): TDynRecord; + // clone this record; register all list records in `registerIn` + // "registration" is required to manage record lifetime; use header record if in doubt + // all fields are cloned too + function clone (registerIn: TDynRecord): TDynRecord; + // compare records (values of all fields, including trigdata) + // WARNING: won't work for records with list fields function isSimpleEqu (rec: TDynRecord): Boolean; + // find field with `TriggerType` type + function trigTypeField (): TDynField; + + // number of records of the given instance + function instanceCount (const atypename: AnsiString): Integer; + + // 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 procedure parseValue (pr: TTextParser; beginEaten: Boolean=false); - procedure parseBinValue (st: TStream; forceData: Boolean=false); + // text writer + // `putHeader`: `true` to write complete header, otherwise only "{...}" procedure writeTo (wr: TTextWriter; putHeader: Boolean=true); - procedure writeBinTo (st: TStream; trigbufsz: Integer=-1; onlyFields: Boolean=false); - // find field with `TriggerType` type - function trigTypeField (): TDynField; + // binary parser and writer (DO NOT USE!) + procedure parseBinValue (st: TStream; forceData: Boolean=false); + procedure writeBinTo (var hasLostData: Boolean; st: TStream; trigbufsz: Integer=-1; onlyFields: Boolean=false); - // number of records of the given instance - function instanceCount (const typename: AnsiString): Integer; + public + property mapdef: TDynMapDef read mOwner; + property id: AnsiString read mId; // record id in text map + 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 + property fieldAt[idx: Integer]: TDynField read getFieldAt; // get field at the given index + property isTrigData: Boolean read getIsTrigData; // is this special "TriggerData" record? + property isForTrig[const aname: AnsiString]: Boolean read getIsForTrig; // can this "TriggerData" be used for the trigger with the given type? + property forTrigCount: Integer read getForTrigCount; // number of trigger type names for "TriggerData" + property forTrigAt[idx: Integer]: AnsiString read getForTrigAt; // trigger type name at the given index for "TriggerData" + 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; - procedure setUserField (const fldname: AnsiString; v: LongInt); - procedure setUserField (const fldname: AnsiString; v: AnsiString); - procedure setUserField (const fldname: AnsiString; v: Boolean); + public + // user fields; user can add arbitrary custom fields + // by default, any user field will be marked as "internal" + // note: you can use this to manipulate non-user fields too + property user[const aname: AnsiString]: Variant read getUserVar write setUserVar; public - property id: AnsiString read mId; // for map parser - property pasname: AnsiString read mPasName; - property name: AnsiString read mName; // record name - property size: Integer read mSize; // size in bytes - //property fields: TDynFieldList read mFields; - property has[const aname: AnsiString]: Boolean read hasByName; - property count: Integer read getCount; - property field[const aname: AnsiString]: TDynField read getFieldByName; default; - property fieldAt[idx: Integer]: TDynField read getFieldAt; - property isTrigData: Boolean read getIsTrigData; - property isForTrig[const aname: AnsiString]: Boolean read getIsForTrig; - property forTrigCount: Integer read getForTrigCount; - property forTrigAt[idx: Integer]: AnsiString read getForTrigAt; - property headerRec: TDynRecord read mHeaderRec; - property isHeader: Boolean read mHeader; - // userdata + // 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; property tagPtr: Pointer read mTagPtr write mTagPtr; end; - TDynEBS = class + + // bitset/enum definition + 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 @@ -291,25 +396,31 @@ type function hasByName (const aname: AnsiString): Boolean; inline; function getFieldByName (const aname: AnsiString): Integer; inline; + function definition (): AnsiString; + function pasdef (): AnsiString; + public constructor Create (pr: TTextParser); // parse definition destructor Destroy (); override; - function definition (): AnsiString; - function pasdef (): AnsiString; - + // find name for the given value // return empty string if not found function nameByValue (v: Integer): AnsiString; public - property name: AnsiString read mName; // record name - property isEnum: Boolean read mIsEnum; + property mapdef: TDynMapDef read mOwner; + 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; - TDynMapDef = class + // parsed "mapdef.txt" + TDynMapDef = class{$IFDEF USE_MEMPOOL}(TPoolObject){$ENDIF} public recTypes: TDynRecList; // [0] is always header trigTypes: TDynRecList; // trigdata @@ -320,9 +431,21 @@ type function getHeaderRecType (): TDynRecord; inline; + function getRecTypeCount (): Integer; inline; + function getRecTypeAt (idx: Integer): TDynRecord; inline; + + function getEBSTypeCount (): Integer; inline; + function getEBSTypeAt (idx: Integer): TDynEBS; inline; + function getTrigTypeCount (): Integer; inline; function getTrigTypeAt (idx: Integer): TDynRecord; inline; + // creates new header record + function parseTextMap (pr: TTextParser): TDynRecord; + + // creates new header record + function parseBinMap (st: TStream): TDynRecord; + public constructor Create (pr: TTextParser); // parses data definition destructor Destroy (); override; @@ -331,19 +454,34 @@ type function findTrigFor (const aname: AnsiString): TDynRecord; function findEBSType (const aname: AnsiString): TDynEBS; - function pasdef (): AnsiString; - function pasdefconst (): AnsiString; + public + // parse text or binary map, return new header record + // WARNING! stream must be seekable + function parseMap (st: TStream; wasBinary: PBoolean=nil): TDynRecord; - // creates new header record - function parseMap (pr: TTextParser): TDynRecord; + // returns `true` if the given stream can be a map file + // stream position is 0 on return + // WARNING! stream must be seekable + class function canBeMap (st: TStream): Boolean; - // creates new header record - function parseBinMap (st: TStream): TDynRecord; + public + // the following functions are here only for 'mapgen'! DO NOT USE! + function pasdefconst (): AnsiString; public property headerType: TDynRecord read getHeaderRecType; + // for record types + property recTypeCount: Integer read getRecTypeCount; + property recTypeAt[idx: Integer]: TDynRecord read getRecTypeAt; + property recType[const aname: AnsiString]: TDynRecord read findRecType; + // for enum/bitset types + property ebsTypeCount: Integer read getEBSTypeCount; + property ebsTypeAt[idx: Integer]: TDynEBS read getEBSTypeAt; + property ebsType[const aname: AnsiString]: TDynEBS read findEBSType; + // for trigtypes property trigTypeCount: Integer read getTrigTypeCount; - property trigType[idx: Integer]: TDynRecord read getTrigTypeAt; + property trigTypeAt[idx: Integer]: TDynRecord read getTrigTypeAt; + property trigTypeFor[const aname: AnsiString]: TDynRecord read findTrigFor; end; @@ -351,12 +489,15 @@ type procedure xdynDumpProfiles (); {$ENDIF} +var + DynWarningCB: procedure (const msg: AnsiString; line, col: Integer) = nil; implementation +{$IF DEFINED(D2D_DYNREC_PROFILER)} uses - SysUtils, e_log - {$IF DEFINED(D2D_DYNREC_PROFILER)},xprofiler{$ENDIF}; + xprofiler; +{$ENDIF} // ////////////////////////////////////////////////////////////////////////// // @@ -364,28 +505,32 @@ function StrEqu (const a, b: AnsiString): Boolean; inline; begin result := (a = // ////////////////////////////////////////////////////////////////////////// // -{ -constructor TDynField.TListEnumerator.Create (alist: TDynRecList); +constructor TDynRecException.Create (const amsg: AnsiString); begin - mList := alist; - mCurIdx := -1; + inherited Create(amsg); end; - -function TDynField.TListEnumerator.MoveNext (): Boolean; inline; +constructor TDynRecException.CreateFmt (const afmt: AnsiString; const args: array of const); begin - Inc(mCurIdx); - result := (mList <> nil) and (mCurIdx < mList.count); + inherited Create(formatstrf(afmt, args)); end; -function TDynField.TListEnumerator.getCurrent (): TDynRecord; inline; +// ////////////////////////////////////////////////////////////////////////// // +constructor TDynParseException.Create (pr: TTextParser; const amsg: AnsiString); begin - result := mList[mCurIdx]; + if (pr <> nil) then begin tokLine := pr.tokLine; tokCol := pr.tokCol; end else begin tokLine := 0; tokCol := 0; end; + inherited Create(amsg); +end; + +constructor TDynParseException.CreateFmt (pr: TTextParser; const afmt: AnsiString; const args: array of const); +begin + if (pr <> nil) then begin tokLine := pr.tokLine; tokCol := pr.tokCol; end else begin tokLine := 0; tokCol := 0; end; + inherited Create(formatstrf(afmt, args)); end; -} +// ////////////////////////////////////////////////////////////////////////// // function TDynField.GetEnumerator (): TDynRecList.TEnumerator; inline; begin //result := TListEnumerator.Create(mRVal); @@ -405,7 +550,7 @@ begin if (mType = TType.TList) then begin mRVal := TDynRecList.Create(); - mRHash := hashNewStrInt(); + mRHash := THashStrInt.Create(); end; end; @@ -417,6 +562,72 @@ begin end; +constructor TDynField.Create (const aname: AnsiString; val: Variant); + procedure setInt32 (v: LongInt); + begin + case mType of + TType.TBool: + if (v = 0) then mIVal := 0 + else if (v = 1) then mIVal := 1 + else raise TDynRecException.Create('cannot convert shortint variant to field value'); + TType.TByte: + if (v >= -128) and (v <= 127) then mIVal := v + else raise TDynRecException.Create('cannot convert shortint variant to field value'); + TType.TUByte: + if (v >= 0) and (v <= 255) then mIVal := v + else raise TDynRecException.Create('cannot convert shortint variant to field value'); + TType.TShort: + if (v >= -32768) and (v <= 32767) then mIVal := v + else raise TDynRecException.Create('cannot convert shortint variant to field value'); + TType.TUShort: + if (v >= 0) and (v <= 65535) then mIVal := v + else raise TDynRecException.Create('cannot convert shortint variant to field value'); + TType.TInt: + mIVal := v; + TType.TUInt: + mIVal := v; + TType.TString: + mSVal := formatstrf('%s', [v]); + else + raise TDynRecException.Create('cannot convert integral variant to field value'); + end; + end; +begin + mRVal := nil; + mRecRef := nil; + mRHash := nil; + cleanup(); + mName := aname; + case varType(val) of + varEmpty: raise TDynRecException.Create('cannot convert empty variant to field value'); + varNull: raise TDynRecException.Create('cannot convert null variant to field value'); + varSingle: raise TDynRecException.Create('cannot convert single variant to field value'); + varDouble: raise TDynRecException.Create('cannot convert double variant to field value'); + varDecimal: raise TDynRecException.Create('cannot convert decimal variant to field value'); + varCurrency: raise TDynRecException.Create('cannot convert currency variant to field value'); + varDate: raise TDynRecException.Create('cannot convert date variant to field value'); + varOleStr: raise TDynRecException.Create('cannot convert olestr variant to field value'); + varStrArg: raise TDynRecException.Create('cannot convert stdarg variant to field value'); + varString: mType := TType.TString; + varDispatch: raise TDynRecException.Create('cannot convert dispatch variant to field value'); + varBoolean: mType := TType.TBool; + varVariant: raise TDynRecException.Create('cannot convert variant variant to field value'); + varUnknown: raise TDynRecException.Create('cannot convert unknown variant to field value'); + varByte: mType := TType.TUByte; + varWord: mType := TType.TUShort; + varShortInt: mType := TType.TByte; + varSmallint: mType := TType.TShort; + varInteger: mType := TType.TInt; + varInt64: raise TDynRecException.Create('cannot convert int64 variant to field value'); + varLongWord: raise TDynRecException.Create('cannot convert longword variant to field value'); + varQWord: raise TDynRecException.Create('cannot convert uint64 variant to field value'); + varError: raise TDynRecException.Create('cannot convert error variant to field value'); + else raise TDynRecException.Create('cannot convert undetermined variant to field value'); + end; + value := val; +end; + + destructor TDynField.Destroy (); begin cleanup(); @@ -427,9 +638,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; @@ -442,12 +657,14 @@ begin mAsT := false; mHasDefault := false; mDefined := false; - mOmitDef := false; + mWriteDef := false; mInternal := true; mDefUnparsed := ''; mDefSVal := ''; mDefIVal := 0; mDefIVal2 := 0; + mDefIVal3 := 0; + mDefIVal4 := 0; // default value for alpha mDefRecRef := nil; mEBS := TEBS.TNone; mEBSTypeName := ''; @@ -458,27 +675,31 @@ begin mRecRefId := ''; mTagInt := 0; mTagPtr := nil; + mAlias := ''; end; -function TDynField.clone (newOwner: TDynRecord=nil): TDynField; +function TDynField.clone (newOwner: TDynRecord=nil; registerIn: TDynRecord=nil): TDynField; var rec: TDynRecord; begin result := TDynField.Create(mName, mType); result.mOwner := mOwner; if (newOwner <> nil) then result.mOwner := newOwner else result.mOwner := mOwner; - result.mPasName := mPasName; 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(); - for rec in mRVal do result.addListItem(rec.clone()); + if (result.mRHash = nil) then result.mRHash := THashStrInt.Create(); + for rec in mRVal do result.addListItem(rec.clone(registerIn)); end; result.mRecRef := mRecRef; result.mMaxDim := mMaxDim; @@ -487,7 +708,7 @@ begin result.mAsT := mAsT; result.mDefined := mDefined; result.mHasDefault := mHasDefault; - result.mOmitDef := mOmitDef; + result.mWriteDef := mWriteDef; result.mInternal := mInternal; result.mNegBool := mNegBool; result.mBitSetUnique := mBitSetUnique; @@ -496,6 +717,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; @@ -503,13 +726,167 @@ begin result.mRecRefId := mRecRefId; result.mTagInt := mTagInt; result.mTagPtr := mTagPtr; + result.mAlias := mAlias; end; -procedure TDynField.setIVal (v: Integer); inline; +function TDynField.palias (firstUp: Boolean=false): AnsiString; +var + nextUp: Boolean; + ch: AnsiChar; begin - //FIXME: check type - mIVal := v; + if (Length(mAlias) > 0) then + begin + if firstUp then result := UpCase1251(mAlias[1])+Copy(mAlias, 2, Length(mAlias)-1) else result := mAlias; + end + else + begin + result := ''; + nextUp := firstUp; + for ch in mName do + begin + if (ch = '_') then begin nextUp := true; continue; end; + if nextUp then result += UpCase1251(ch) else result += ch; + nextUp := false; + end; + end; +end; + + +procedure TDynField.setRecRef (arec: TDynRecord); +var + trc: TDynRecord = nil; +begin + case mEBS of + TEBS.TNone: raise TDynRecException.CreateFmt('cannot set refrec for non-reference field ''%s''', [mName]); + TEBS.TRec: + begin + if (arec <> nil) then + begin + if (mEBSType <> nil) and (mEBSType is TDynRecord) then trc := (mEBSType as TDynRecord); + if (trc = nil) then raise TDynRecException.CreateFmt('cannot set refrec for field ''%s'' (type conflict: improperly initialized field)', [mName]); + if (trc.typeName <> arec.typeName) then raise TDynRecException.CreateFmt('cannot set refrec for field ''%s'' (type conflict: expected ''%s'' got ''%s'')', [mName, trc.typeName, arec.typeName]); + end; + mRecRef := arec; + mDefined := true; + exit; + end; + TEBS.TEnum: raise TDynRecException.CreateFmt('cannot set refrec for enum field ''%s''', [mName]); + TEBS.TBitSet: raise TDynRecException.CreateFmt('cannot set refrec for bitset field ''%s''', [mName]); + else raise TDynRecException.Create('ketmar forgot to process some reftypes'); + end; +end; + + +function TDynField.getVar (): Variant; +begin + if (mEBS = TEBS.TRec) then begin result := LongInt(getRecRefIndex); exit; end; + case mType of + TType.TBool: result := (mIVal <> 0); + TType.TChar: result := mSVal; + TType.TByte: result := ShortInt(mIVal); + TType.TUByte: result := Byte(mIVal); + TType.TShort: result := SmallInt(mIVal); + TType.TUShort: result := Word(mIVal); + TType.TInt: result := LongInt(mIVal); + TType.TUInt: result := LongWord(mIVal); + 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'); + end; +end; + + +procedure TDynField.setVar (val: Variant); + procedure setInt32 (v: LongInt); + begin + case mType of + TType.TBool: + if (v = 0) then mIVal := 0 + else if (v = 1) then mIVal := 1 + else raise TDynRecException.Create('cannot convert shortint variant to field value'); + TType.TByte: + if (v >= -128) and (v <= 127) then mIVal := v + else raise TDynRecException.Create('cannot convert shortint variant to field value'); + TType.TUByte: + if (v >= 0) and (v <= 255) then mIVal := v + else raise TDynRecException.Create('cannot convert shortint variant to field value'); + TType.TShort: + if (v >= -32768) and (v <= 32767) then mIVal := v + else raise TDynRecException.Create('cannot convert shortint variant to field value'); + TType.TUShort: + if (v >= 0) and (v <= 65535) then mIVal := v + else raise TDynRecException.Create('cannot convert shortint variant to field value'); + TType.TInt: + mIVal := v; + TType.TUInt: + mIVal := v; + TType.TString: + mSVal := formatstrf('%s', [v]); + else + raise TDynRecException.Create('cannot convert integral variant to field value'); + end; + end; +begin + case varType(val) of + varEmpty: raise TDynRecException.Create('cannot convert empty variant to field value'); + varNull: raise TDynRecException.Create('cannot convert null variant to field value'); + varSingle: raise TDynRecException.Create('cannot convert single variant to field value'); + varDouble: raise TDynRecException.Create('cannot convert double variant to field value'); + varDecimal: raise TDynRecException.Create('cannot convert decimal variant to field value'); + varCurrency: raise TDynRecException.Create('cannot convert currency variant to field value'); + varDate: raise TDynRecException.Create('cannot convert date variant to field value'); + varOleStr: raise TDynRecException.Create('cannot convert olestr variant to field value'); + varStrArg: raise TDynRecException.Create('cannot convert stdarg variant to field value'); + varString: + if (mType = TType.TChar) or (mType = TType.TString) then + begin + mSVal := val; + end + else + begin + raise TDynRecException.Create('cannot convert string variant to field value'); + end; + varDispatch: raise TDynRecException.Create('cannot convert dispatch variant to field value'); + varBoolean: + case mType of + TType.TBool, + TType.TByte, + TType.TUByte, + TType.TShort, + TType.TUShort, + TType.TInt, + TType.TUInt: + if val then mIVal := 1 else mIVal := 0; + TType.TString: + if val then mSVal := 'true' else mSVal := 'false'; + else + raise TDynRecException.Create('cannot convert boolean variant to field value'); + end; + varVariant: raise TDynRecException.Create('cannot convert variant variant to field value'); + varUnknown: raise TDynRecException.Create('cannot convert unknown variant to field value'); + varByte, + varWord, + varShortInt, + varSmallint, + varInteger: + setInt32(val); + varInt64: + if (val < Int64(LongInt($80000000))) or (val > LongInt($7FFFFFFF)) then + raise TDynRecException.Create('cannot convert boolean variant to field value') + else + mIVal := LongInt(val); + varLongWord: + if (val > LongWord($7FFFFFFF)) then raise TDynRecException.Create('cannot convert longword variant to field value') + else setInt32(Integer(val)); + varQWord: raise TDynRecException.Create('cannot convert uint64 variant to field value'); + varError: raise TDynRecException.Create('cannot convert error variant to field value'); + else raise TDynRecException.Create('cannot convert undetermined variant to field value'); + end; mDefined := true; end; @@ -532,13 +909,15 @@ 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 if (mRecRef = nil) then begin result := (fld.mRecRef = nil); exit; end; result := mRecRef.isSimpleEqu(fld.mRecRef); end; - else raise Exception.Create('ketmar forgot to handle some field type'); + else raise TDynRecException.Create('ketmar forgot to handle some field type'); end; end; @@ -556,11 +935,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 @@ -569,6 +961,8 @@ begin mDefSVal := ''; mDefIVal := 0; mDefIVal2 := 0; + mDefIVal3 := 0; + mDefIVal4 := 0; // default value for alpha mDefRecRef := nil; end else @@ -576,19 +970,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(); @@ -604,12 +1005,15 @@ begin if not mHasDefault then begin if mInternal then exit; - raise Exception.Create(Format('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; @@ -622,6 +1026,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; @@ -659,6 +1064,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 @@ -673,17 +1098,19 @@ 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 Exception.Create('ketmar forgot to handle some field type'); + else raise TDynRecException.Create('ketmar forgot to handle some field type'); end; end; function TDynField.definition (): AnsiString; begin - result := mPasName+' is '+quoteStr(mName)+' type '; + result := quoteStr(mName)+' type '; result += getTypeName(mType); + if (Length(mAlias) > 0) then result += ' alias '+mAlias; if (mMaxDim >= 0) then result += Format('[%d]', [mMaxDim]); if (mBinOfs >= 0) then result += Format(' offset %d', [mBinOfs]); case mEBS of @@ -699,51 +1126,22 @@ begin if (mType = TType.TPoint) then begin if (mAsT) then result += ' as txy' else result += ' as xy'; end else if (mType = TType.TSize) then begin if (mAsT) then result += ' as twh' else result += ' as wh'; end; end; - if mOmitDef then result += ' omitdefault'; + if mWriteDef then result += ' writedefault'; if mInternal then result += ' internal'; end; -function TDynField.pasdef (): AnsiString; -begin - result := mPasName+': '; - case mType of - TType.TBool: result += 'Boolean;'; - TType.TChar: if (mMaxDim > 0) then result += formatstrf('Char%d;', [mMaxDim]) else result += 'Char;'; - TType.TByte: result += 'ShortInt;'; - TType.TUByte: result += 'Byte;'; - TType.TShort: result += 'SmallInt;'; - TType.TUShort: result += 'Word;'; - TType.TInt: result += 'LongInt;'; - TType.TUInt: result += 'LongWord;'; - TType.TString: result += 'AnsiString;'; - TType.TPoint: - if mAsT then result := 'tX, tY: Integer;' - else if mSepPosSize then result := 'X, Y: Integer;' - else result += 'TDFPoint;'; - TType.TSize: - if mAsT then result := 'tWidth, tHeight: Word;' - else if mSepPosSize then result := 'Width, Height: Word;' - else result += 'TSize;'; - TType.TList: assert(false); - TType.TTrigData: result += formatstrf('Byte%d;', [mMaxDim]); - else raise Exception.Create('ketmar forgot to handle some field type'); - end; -end; - - procedure TDynField.parseDef (pr: TTextParser); var fldname: AnsiString; fldtype: AnsiString; fldofs: Integer; fldrecname: AnsiString; - fldpasname: AnsiString; asxy, aswh, ast: Boolean; ainternal: Boolean; - omitdef: Boolean; + writedef: Boolean; defstr: AnsiString; - defint: Integer; + defint, defint2, defint3, defint4: Integer; hasdefStr: Boolean; hasdefInt: Boolean; hasdefId: Boolean; @@ -751,8 +1149,10 @@ var lebs: TDynField.TEBS; unique: Boolean; asmonid: Boolean; + defech: AnsiChar; + xalias: AnsiString; + atip, ahelp: AnsiString; begin - fldpasname := ''; fldname := ''; fldtype := ''; fldofs := -1; @@ -761,9 +1161,12 @@ begin aswh := false; ast := false; ainternal := false; - omitdef := false; + writedef := false; defstr := ''; defint := 0; + defint2 := 0; + defint3 := 0; + defint4 := 0; hasdefStr := false; hasdefInt := false; hasdefId := false; @@ -771,30 +1174,57 @@ begin asmonid := false; lmaxdim := -1; lebs := TDynField.TEBS.TNone; + xalias := ''; + atip := ''; + ahelp := ''; - fldpasname := pr.expectId(); // pascal field name // field name - pr.expectId('is'); - fldname := pr.expectStr(); - // field type - pr.expectId('type'); - fldtype := pr.expectId(); + fldname := pr.expectIdOrStr(); - // fixed-size array? - if pr.eatDelim('[') then + while (not pr.isDelim(';')) do begin - lmaxdim := pr.expectInt(); - if (lmaxdim < 1) then raise Exception.Create(Format('invalid field ''%s'' array size', [fldname])); - pr.expectDelim(']'); - end; + if pr.eatId('type') then + begin + if (Length(fldtype) > 0) then raise TDynParseException.CreateFmt(pr, 'duplicate type definition for field ''%s''', [fldname]); + // field type + fldtype := pr.expectId(); + // fixed-size array? + if pr.eatDelim('[') then + begin + lmaxdim := pr.expectInt(); + // arbitrary limits + if (lmaxdim < 1) or (lmaxdim > 32768) then raise TDynParseException.CreateFmt(pr, 'invalid field ''%s'' array size', [fldname]); + pr.expectDelim(']'); + end; + continue; + end; + + if pr.eatId('alias') then + begin + if (Length(xalias) > 0) then raise TDynParseException.CreateFmt(pr, 'duplicate alias definition for field ''%s''', [fldname]); + xalias := pr.expectId(); + 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; - while (pr.tokType <> pr.TTSemi) do - begin if pr.eatId('offset') then begin - if (fldofs >= 0) then raise Exception.Create(Format('duplicate field ''%s'' offset', [fldname])); + if (fldofs >= 0) then raise TDynParseException.CreateFmt(pr, 'duplicate field ''%s'' offset', [fldname]); fldofs := pr.expectInt(); - if (fldofs < 0) then raise Exception.Create(Format('invalid field ''%s'' offset', [fldname])); + if (fldofs < 0) then raise TDynParseException.CreateFmt(pr, 'invalid field ''%s'' offset', [fldname]); continue; end; @@ -805,14 +1235,14 @@ begin else if pr.eatId('txy') then begin asxy := true; ast := true; end else if pr.eatId('twh') then begin aswh := true; ast := true; end else if pr.eatId('monsterid') then begin asmonid := true; end - else raise Exception.Create(Format('invalid field ''%s'' as what?', [fldname])); + else raise TDynParseException.CreateFmt(pr, 'invalid field ''%s'' as what?', [fldname]); continue; end; if pr.eatId('enum') then begin lebs := TDynField.TEBS.TEnum; - if (Length(fldrecname) <> 0) then raise Exception.Create(Format('field ''%s'' already typed as ''%s''', [fldname, fldrecname])); + if (Length(fldrecname) <> 0) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' already typed as ''%s''', [fldname, fldrecname]); fldrecname := pr.expectId(); continue; end; @@ -820,7 +1250,7 @@ begin if pr.eatId('bitset') then begin lebs := TDynField.TEBS.TBitSet; - if (Length(fldrecname) <> 0) then raise Exception.Create(Format('field ''%s'' already typed as ''%s''', [fldname, fldrecname])); + if (Length(fldrecname) <> 0) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' already typed as ''%s''', [fldname, fldrecname]); unique := pr.eatId('unique'); fldrecname := pr.expectId(); continue; @@ -828,7 +1258,7 @@ begin if pr.eatId('default') then begin - if hasdefStr or hasdefInt or hasdefId then raise Exception.Create(Format('field ''%s'' has duplicate default', [fldname])); + if hasdefStr or hasdefInt or hasdefId then raise TDynParseException.CreateFmt(pr, 'field ''%s'' has duplicate default', [fldname]); case pr.tokType of pr.TTStr: begin @@ -845,15 +1275,28 @@ begin hasdefInt := true; defint := pr.expectInt(); end; + pr.TTDelim: + begin + hasdefInt := true; + 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 - raise Exception.Create(Format('field ''%s'' has invalid default', [fldname])); + raise TDynParseException.CreateFmt(pr, 'field ''%s'' has invalid default', [fldname]); end; continue; end; - if pr.eatId('omitdefault') then + if pr.eatId('writedefault') then begin - omitdef := true; + writedef := true; continue; end; @@ -863,14 +1306,15 @@ begin continue; end; - if (pr.tokType <> pr.TTId) then raise Exception.Create(Format('field ''%s'' has something unexpected in definition', [fldname])); + // record type, no special modifiers + if (pr.tokType <> pr.TTId) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' has something unexpected in definition', [fldname]); - if (Length(fldrecname) <> 0) then raise Exception.Create(Format('field ''%s'' already typed as ''%s''', [fldname, fldrecname])); + if (Length(fldrecname) <> 0) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' already typed as ''%s''', [fldname, fldrecname]); fldrecname := pr.expectId(); lebs := TDynField.TEBS.TRec; end; - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); // create field mName := fldname; @@ -886,23 +1330,54 @@ 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 raise Exception.Create(Format('field ''%s'' has invalid type ''%s''', [fldname, fldtype])); + else + begin + // record types defaults to int + if (Length(fldrecname) > 0) then + begin + mType := TType.TInt; + end + else + begin + if (Length(fldtype) = 0) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' has no type', [fldname]) + else raise TDynParseException.CreateFmt(pr, 'field ''%s'' has invalid type ''%s''', [fldname, fldtype]); + end; + end; + + // check for valid arrays + if (lmaxdim > 0) and (mType <> TType.TChar) and (mType <> TType.TTrigData) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' of type ''%s'' cannot be array', [fldname, fldtype]); - if (lmaxdim > 0) and (mType <> TType.TChar) and (mType <> TType.TTrigData) then raise Exception.Create(Format('field ''%s'' of type ''%s'' cannot be array', [fldname, fldtype])); + // check for valid trigdata or record type if (mType = TType.TTrigData) then begin - if (lmaxdim < 1) then raise Exception.Create(Format('field ''%s'' of type ''%s'' cannot be array', [fldname, fldtype])); - if (Length(fldrecname) > 0) then raise Exception.Create(Format('field ''%s'' of type ''%s'' cannot have another type', [fldname, fldtype])); + // trigdata + if (lmaxdim < 1) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' of type ''%s'' cannot be non-array', [fldname, 'trigdata']); + if (Length(fldrecname) > 0) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' of type ''%s'' cannot have another type', [fldname, 'trigdata']); lebs := TDynField.TEBS.TRec; + end + else if (Length(fldrecname) > 0) then + begin + // record + if not (mType in [TType.TByte, TType.TUByte, TType.TShort, TType.TUShort, TType.TInt, TType.TUInt]) then + begin + raise TDynParseException.CreateFmt(pr, 'field ''%s'' of record type ''%s'' cannot have type ''%s''', [fldname, fldrecname, fldtype]); + end; end; + // setup default value if hasdefStr then self.mDefUnparsed := quoteStr(defstr) - else if hasdefInt then self.mDefUnparsed := Format('%d', [defint]) - else if hasdefId then self.mDefUnparsed := defstr; + else if hasdefId then self.mDefUnparsed := defstr + else if hasdefInt then + 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; self.mHasDefault := (hasdefStr or hasdefId or hasdefInt); - self.mPasName := fldpasname; self.mEBS := lebs; self.mEBSTypeName := fldrecname; self.mBitSetUnique := unique; @@ -911,8 +1386,11 @@ begin self.mBinOfs := fldofs; self.mSepPosSize := (asxy or aswh); self.mAsT := ast; - self.mOmitDef := omitdef; + self.mWriteDef := writedef; self.mInternal := ainternal; + self.mAlias := xalias; + self.mTip := atip; + self.mHelp := ahelp; end; @@ -923,7 +1401,7 @@ begin end; -procedure TDynField.writeBinTo (st: TStream); +procedure TDynField.writeBinTo (var hasLostData: Boolean; st: TStream); var s: AnsiString; f: Integer; @@ -940,17 +1418,17 @@ begin // this must be triggerdata if (mType <> TType.TTrigData) then begin - raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName])); + raise TDynRecException.CreateFmt('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName]); end; // write triggerdata GetMem(buf, mMaxDim); - if (buf = nil) then raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName])); + if (buf = nil) then raise TDynRecException.CreateFmt('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName]); try FillChar(buf^, mMaxDim, 0); 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 @@ -967,15 +1445,15 @@ begin TType.TUShort: maxv := 65534; TType.TInt: maxv := $7fffffff; TType.TUInt: maxv := $7fffffff; - else raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName])); + else raise TDynRecException.CreateFmt('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName]); end; // find record number if (mRecRef <> nil) then begin f := mOwner.findRecordNumByType(mEBSTypeName, mRecRef); - if (f < 0) then raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' not found in record list', [mEBSTypeName, mName])); + if (f < 0) then raise TDynRecException.CreateFmt('record reference type ''%s'' in field ''%s'' not found in record list', [mEBSTypeName, mName]); if mAsMonsterId then Inc(f); - if (f > maxv) then raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' has too big index', [mEBSTypeName, mName])); + if (f > maxv) then raise TDynRecException.CreateFmt('record reference type ''%s'' in field ''%s'' has too big index', [mEBSTypeName, mName]); end else begin @@ -985,13 +1463,13 @@ begin TType.TByte, TType.TUByte: writeInt(st, Byte(f)); TType.TShort, TType.TUShort: writeInt(st, SmallInt(f)); TType.TInt, TType.TUInt: writeInt(st, LongWord(f)); - else raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName])); + else raise TDynRecException.CreateFmt('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName]); end; exit; end; TEBS.TEnum: begin end; TEBS.TBitSet: begin end; - else raise Exception.Create('ketmar forgot to handle some EBS type'); + else raise TDynRecException.Create('ketmar forgot to handle some EBS type'); end; case mType of @@ -1009,15 +1487,15 @@ begin end; TType.TChar: begin - if (mMaxDim = 0) then raise Exception.Create(Format('invalid string size definition for field ''%s''', [mName])); + if (mMaxDim = 0) then raise TDynRecException.CreateFmt('invalid string size definition for field ''%s''', [mName]); if (mMaxDim < 0) then begin - if (Length(mSVal) <> 1) then raise Exception.Create(Format('invalid string size definition for field ''%s''', [mName])); + if (Length(mSVal) <> 1) then raise TDynRecException.CreateFmt('invalid string size definition for field ''%s''', [mName]); writeInt(st, Byte(mSVal[1])); end else begin - if (Length(mSVal) > mMaxDim) then raise Exception.Create(Format('invalid string size definition for field ''%s''', [mName])); + if (Length(mSVal) > mMaxDim) then raise TDynRecException.CreateFmt('invalid string size definition for field ''%s''', [mName]); s := utf2win(mSVal); if (Length(s) > 0) then st.WriteBuffer(PChar(s)^, Length(s)); for f := Length(s) to mMaxDim do writeInt(st, Byte(0)); @@ -1028,53 +1506,57 @@ begin TType.TUByte: begin // triggerdata array was processed earlier - if (mMaxDim >= 0) then Exception.Create(Format('byte array in field ''%s'' cannot be written', [mName])); + if (mMaxDim >= 0) then TDynRecException.CreateFmt('byte array in field ''%s'' cannot be written', [mName]); writeInt(st, Byte(mIVal)); exit; end; TType.TShort, TType.TUShort: begin - if (mMaxDim >= 0) then raise Exception.Create(Format('short array in field ''%s'' cannot be written', [mName])); + if (mMaxDim >= 0) then raise TDynRecException.CreateFmt('short array in field ''%s'' cannot be written', [mName]); writeInt(st, Word(mIVal)); exit; end; TType.TInt, TType.TUInt: begin - if (mMaxDim >= 0) then raise Exception.Create(Format('int array in field ''%s'' cannot be written', [mName])); + if (mMaxDim >= 0) then raise TDynRecException.CreateFmt('int array in field ''%s'' cannot be written', [mName]); writeInt(st, LongWord(mIVal)); exit; end; TType.TString: begin - raise Exception.Create(Format('cannot write string field ''%s''', [mName])); + raise TDynRecException.CreateFmt('cannot write string field ''%s''', [mName]); end; TType.TPoint: begin - if (mMaxDim >= 0) then raise Exception.Create(Format('pos/size array in field ''%s'' cannot be written', [mName])); + if (mMaxDim >= 0) then raise TDynRecException.CreateFmt('pos/size array in field ''%s'' cannot be written', [mName]); writeInt(st, LongInt(mIVal)); writeInt(st, LongInt(mIVal2)); exit; end; TType.TSize: begin - if (mMaxDim >= 0) then raise Exception.Create(Format('pos/size array in field ''%s'' cannot be written', [mName])); + if (mMaxDim >= 0) then raise TDynRecException.CreateFmt('pos/size array in field ''%s'' cannot be written', [mName]); writeInt(st, Word(mIVal)); 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; - else raise Exception.Create('ketmar forgot to handle some field type'); + raise TDynRecException.Create('cannot write triggers to binary format (internal error)'); + else raise TDynRecException.Create('ketmar forgot to handle some field type'); end; end; @@ -1109,10 +1591,10 @@ begin TEBS.TEnum: begin //def := mOwner.mOwner; - //es := def.findEBSType(mEBSTypeName); + //es := def.ebsType[mEBSTypeName]; es := nil; if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS); - if (es = nil) or (not es.mIsEnum) then raise Exception.Create(Format('record enum type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName])); + if (es = nil) or (not es.mIsEnum) then raise TDynRecException.CreateFmt('record enum type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]); for f := 0 to High(es.mVals) do begin if (es.mVals[f] = mIVal) then @@ -1122,15 +1604,15 @@ begin exit; end; end; - raise Exception.Create(Format('value %d in record enum type ''%s'' for field ''%s'' not found', [mIVal, mEBSTypeName, mName])); + raise TDynRecException.CreateFmt('value %d in record enum type ''%s'' for field ''%s'' not found', [mIVal, mEBSTypeName, mName]); end; TEBS.TBitSet: begin //def := mOwner.mOwner; - //es := def.findEBSType(mEBSTypeName); + //es := def.ebsType[mEBSTypeName]; es := nil; if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS); - if (es = nil) or es.mIsEnum then raise Exception.Create(Format('record bitset type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName])); + if (es = nil) or es.mIsEnum then raise TDynRecException.CreateFmt('record bitset type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]); // none? if (mIVal = 0) then begin @@ -1143,7 +1625,7 @@ begin exit; end; end; - raise Exception.Create(Format('value %d in record bitset type ''%s'' for field ''%s'' not found', [0, mEBSTypeName, mName])); + raise TDynRecException.CreateFmt('value %d in record bitset type ''%s'' for field ''%s'' not found', [0, mEBSTypeName, mName]); end; // not none mask := 1; @@ -1157,20 +1639,20 @@ 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; end; end; - if not found then raise Exception.Create(Format('value %d in record bitset type ''%s'' for field ''%s'' not found', [mask, mEBSTypeName, mName])); + if not found then raise TDynRecException.CreateFmt('value %d in record bitset type ''%s'' for field ''%s'' not found', [mask, mEBSTypeName, mName]); end; mask := mask shl 1; end; wr.put(';'#10); exit; end; - else raise Exception.Create('ketmar forgot to handle some EBS type'); + else raise TDynRecException.Create('ketmar forgot to handle some EBS type'); end; case mType of @@ -1181,7 +1663,7 @@ begin end; TType.TChar: begin - if (mMaxDim = 0) then raise Exception.Create(Format('invalid string size definition for field ''%s''', [mName])); + if (mMaxDim = 0) then raise TDynRecException.CreateFmt('invalid string size definition for field ''%s''', [mName]); wr.put(quoteStr(mSVal)); wr.put(';'#10); exit; @@ -1208,6 +1690,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); @@ -1218,9 +1706,9 @@ begin assert(false); exit; end; - else raise Exception.Create('ketmar forgot to handle some field type'); + else raise TDynRecException.Create('ketmar forgot to handle some field type'); end; - raise Exception.Create(Format('cannot parse field ''%s'' yet', [mName])); + raise TDynRecException.CreateFmt('cannot parse field ''%s'' yet', [mName]); end; @@ -1244,18 +1732,14 @@ begin rec := mOwner; // find trigger definition tfld := rec.trigTypeField(); - if (tfld = nil) then raise Exception.Create(Format('triggerdata value for field ''%s'' in record ''%s'' without TriggerType field', [mName, rec.mName])); - rc := mOwner.mOwner.findTrigFor(tfld.mSVal); // find in mapdef - if (rc = nil) then raise Exception.Create(Format('triggerdata definition for field ''%s'' in record ''%s'' with type ''%s'' not found', [mName, rec.mName, tfld.mSVal])); - rc := rc.clone(); + 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.mTypeName, tfld.mSVal]); + rc := rc.clone(mOwner.mHeaderRec); rc.mHeaderRec := mOwner.mHeaderRec; - try - rc.parseBinValue(st, true); - mRecRef := rc; - rc := nil; - finally - rc.Free(); - end; + // on error, it will be freed by memowner + rc.parseBinValue(st, true); + mRecRef := rc; mDefined := true; exit; end @@ -1269,7 +1753,7 @@ begin TType.TUShort: f := readWord(st); TType.TInt: f := readLongInt(st); TType.TUInt: f := readLongWord(st); - else raise Exception.Create(Format('invalid non-numeric type ''%s'' for field ''%s'' of record ''%s''', [getTypeName(mType), mName, mEBSTypeName])); + else raise TDynRecException.CreateFmt('invalid non-numeric type ''%s'' for field ''%s'' of record ''%s''', [getTypeName(mType), mName, mEBSTypeName]); end; if mAsMonsterId then Dec(f); if (f < 0) then mRecRefId := '' else mRecRefId := Format('%s%d', [mEBSTypeName, f]); @@ -1288,17 +1772,17 @@ begin TType.TUShort: f := readWord(st); TType.TInt: f := readLongInt(st); TType.TUInt: f := readLongWord(st); - else raise Exception.Create(Format('invalid non-numeric type ''%s'' for field ''%s'' of record ''%s''', [getTypeName(mType), mName, mEBSTypeName])); + else raise TDynRecException.CreateFmt('invalid non-numeric type ''%s'' for field ''%s'' of record ''%s''', [getTypeName(mType), mName, mEBSTypeName]); end; es := nil; if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS); - if (es = nil) or (es.mIsEnum <> (mEBS = TEBS.TEnum)) then raise Exception.Create(Format('record enum type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName])); + if (es = nil) or (es.mIsEnum <> (mEBS = TEBS.TEnum)) then raise TDynRecException.CreateFmt('record enum type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]); mIVal := f; // build enum/bitfield values if (mEBS = TEBS.TEnum) then begin mSVal := es.nameByValue(mIVal); - if (Length(mSVal) = 0) then raise Exception.Create(Format('record enum type ''%s'' for field ''%s'' has invalid value %d', [mEBSTypeName, mName, mIVal])); + if (Length(mSVal) = 0) then raise TDynRecException.CreateFmt('record enum type ''%s'' for field ''%s'' has invalid value %d', [mEBSTypeName, mName, mIVal]); end else begin @@ -1306,7 +1790,7 @@ begin if (mIVal = 0) then begin mSVal := es.nameByValue(mIVal); - if (Length(mSVal) = 0) then raise Exception.Create(Format('record bitset type ''%s'' for field ''%s'' has invalid value %d', [mEBSTypeName, mName, mIVal])); + if (Length(mSVal) = 0) then raise TDynRecException.CreateFmt('record bitset type ''%s'' for field ''%s'' has invalid value %d', [mEBSTypeName, mName, mIVal]); end else begin @@ -1317,7 +1801,7 @@ begin if ((mIVal and mask) <> 0) then begin s := es.nameByValue(mask); - if (Length(s) = 0) then raise Exception.Create(Format('record bitset type ''%s'' for field ''%s'' has invalid value %d', [mEBSTypeName, mName, mask])); + if (Length(s) = 0) then raise TDynRecException.CreateFmt('record bitset type ''%s'' for field ''%s'' has invalid value %d', [mEBSTypeName, mName, mask]); if (Length(mSVal) <> 0) then mSVal += '+'; mSVal += s; end; @@ -1329,7 +1813,7 @@ begin mDefined := true; exit; end; - else raise Exception.Create('ketmar forgot to handle some EBS type'); + else raise TDynRecException.Create('ketmar forgot to handle some EBS type'); end; case mType of @@ -1377,7 +1861,7 @@ begin TType.TUInt: begin mIVal := readLongWord(st); mDefined := true; exit; end; TType.TString: begin - raise Exception.Create('cannot read strings from binaries yet'); + raise TDynRecException.Create('cannot read strings from binaries yet'); exit; end; TType.TPoint: @@ -1394,6 +1878,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); @@ -1404,9 +1898,9 @@ begin assert(false); exit; end; - else raise Exception.Create('ketmar forgot to handle some field type'); + else raise TDynRecException.Create('ketmar forgot to handle some field type'); end; - raise Exception.Create(Format('cannot parse field ''%s'' yet', [mName])); + raise TDynRecException.CreateFmt('cannot parse field ''%s'' yet', [mName]); end; @@ -1415,7 +1909,7 @@ procedure TDynField.parseValue (pr: TTextParser); procedure parseInt (min, max: Integer); begin mIVal := pr.expectInt(); - if (mIVal < min) or (mIVal > max) then raise Exception.Create(Format('invalid %s value for field ''%s''', [getTypeName(mType), mName])); + if (mIVal < min) or (mIVal > max) then raise TDynParseException.CreateFmt(pr, 'invalid %s value for field ''%s''', [getTypeName(mType), mName]); mDefined := true; end; @@ -1426,6 +1920,8 @@ var tk: AnsiString; edim: AnsiChar; begin + if (pr.tokType = pr.TTEOF) then raise TDynParseException.Create(pr, 'field value expected'); + 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; @@ -1434,34 +1930,29 @@ 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 Exception.Create(Format('triggerdata value for field ''%s'' in record ''%s'' without ''type'' field', [mName, rec.mName])); - rc := mOwner.mOwner.findTrigFor(tfld.mSVal); // find in mapdef - if (rc = nil) then raise Exception.Create(Format('triggerdata definition for field ''%s'' in record ''%s'' with type ''%s'' not found', [mName, rec.mName, tfld.mSVal])); - rc := rc.clone(); + 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.mTypeName, tfld.mSVal]); + rc := rc.clone(mOwner.mHeaderRec); rc.mHeaderRec := mOwner.mHeaderRec; //writeln(rc.definition); - try - rc.parseValue(pr, true); - mRecRef := rc; - rc := nil; - finally - rc.Free(); - end; + // on error, it will be freed by memowner + rc.parseValue(pr, true); + 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 @@ -1474,73 +1965,78 @@ begin else begin rec := mOwner.findRecordByTypeId(mEBSTypeName, pr.tokStr); - if (rec = nil) then raise Exception.Create(Format('record ''%s'' (%s) value for field ''%s'' not found', [pr.tokStr, mEBSTypeName, mName])); + if (rec = nil) then + begin + mRecRefId := pr.tokStr; + end + else + begin + mRecRef := rec; + mRecRefId := ''; + end; pr.expectId(); - mRecRef := rec; 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.findRecType(mEBSTypeName); // find in mapdef + //rec := mOwner.mOwner.recType[mEBSTypeName]; // find in mapdef rec := nil; if (mEBSType <> nil) and (mEBSType is TDynRecord) then rec := (mEBSType as TDynRecord); - if (rec = nil) then raise Exception.Create(Format('record type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName])); - rc := rec.clone(); + if (rec = nil) then raise TDynParseException.CreateFmt(pr, 'record type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]); + rc := rec.clone(mOwner.mHeaderRec); rc.mHeaderRec := mOwner.mHeaderRec; rc.parseValue(pr); mRecRef := rc; mDefined := true; if mOwner.addRecordByType(mEBSTypeName, rc) then begin - //raise Exception.Create(Format('record type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName])); - e_LogWritefln('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 - //es := mOwner.mOwner.findEBSType(mEBSTypeName); // find in mapdef + //es := mOwner.mOwner.ebsType[mEBSTypeName]; // find in mapdef es := nil; if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS); - if (es = nil) or (not es.mIsEnum) then raise Exception.Create(Format('record enum type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName])); + if (es = nil) or (not es.mIsEnum) then raise TDynParseException.CreateFmt(pr, 'record enum type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]); tk := pr.expectId(); - if not es.has[tk] then raise Exception.Create(Format('record enum value ''%s'' of type ''%s'' for field ''%s'' not found', [tk, mEBSTypeName, mName])); + if not es.has[tk] then raise TDynParseException.CreateFmt(pr, 'record enum value ''%s'' of type ''%s'' for field ''%s'' not found', [tk, mEBSTypeName, mName]); mIVal := es.field[tk]; mSVal := tk; //writeln('ENUM ', mEBSName, '; element <', mSVal, '> with value ', mIVal); mDefined := true; - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); exit; end; TEBS.TBitSet: begin - //es := mOwner.mOwner.findEBSType(mEBSTypeName); // find in mapdef + //es := mOwner.mOwner.ebsType[mEBSTypeName]; // find in mapdef es := nil; if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS); - if (es = nil) or es.mIsEnum then raise Exception.Create(Format('record bitset type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName])); + if (es = nil) or es.mIsEnum then raise TDynParseException.CreateFmt(pr, 'record bitset type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]); mIVal := 0; while true do begin tk := pr.expectId(); - if not es.has[tk] then raise Exception.Create(Format('record bitset value ''%s'' of type ''%s'' for field ''%s'' not found', [tk, mEBSTypeName, mName])); + if not es.has[tk] then raise TDynParseException.CreateFmt(pr, 'record bitset value ''%s'' of type ''%s'' for field ''%s'' not found', [tk, mEBSTypeName, mName]); mIVal := mIVal or es.field[tk]; mSVal := tk; if (pr.tokType <> pr.TTDelim) or ((pr.tokChar <> '|') and (pr.tokChar <> '+')) then break; - if mBitSetUnique then raise Exception.Create(Format('record bitset of type ''%s'' for field ''%s'' expects only one value', [tk, mEBSTypeName, mName])); - //pr.expectDelim('|'); + if mBitSetUnique then raise TDynParseException.CreateFmt(pr, 'record bitset of type ''%s'' for field ''%s'' expects only one value', [tk, mEBSTypeName, mName]); pr.skipToken(); // plus or pipe end; mDefined := true; - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); exit; end; - else raise Exception.Create('ketmar forgot to handle some EBS type'); + else raise TDynParseException.Create(pr, 'ketmar forgot to handle some EBS type'); end; case mType of @@ -1548,72 +2044,72 @@ begin begin if pr.eatId('true') or pr.eatId('tan') or pr.eatId('yes') then mIVal := 1 else if pr.eatId('false') or pr.eatId('ona') or pr.eatId('no') then mIVal := 0 - else raise Exception.Create(Format('invalid bool value for field ''%s''', [mName])); + else raise TDynParseException.CreateFmt(pr, 'invalid bool value for field ''%s''', [mName]); mDefined := true; - pr.expectTT(pr.TTSemi); + pr.expectDelim(';'); exit; end; TType.TChar: begin - if (mMaxDim = 0) then raise Exception.Create(Format('invalid string size definition for field ''%s''', [mName])); + if (mMaxDim = 0) then raise TDynParseException.CreateFmt(pr, 'invalid string size definition for field ''%s''', [mName]); mSVal := pr.expectStr(true); if (mMaxDim < 0) then begin // single char - if (Length(mSVal) <> 1) then raise Exception.Create(Format('invalid string size for field ''%s''', [mName])); + if (Length(mSVal) <> 1) then raise TDynParseException.CreateFmt(pr, 'invalid string size for field ''%s''', [mName]); mIVal := Integer(mSVal[1]); mSVal := ''; end else begin // string - if (Length(mSVal) > mMaxDim) then raise Exception.Create(Format('invalid string size for field ''%s''', [mName])); + 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, @@ -1623,16 +2119,39 @@ begin mIVal := pr.expectInt(); if (mType = TType.TSize) then begin - if (mIVal < 0) or (mIVal > 32767) then raise Exception.Create(Format('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 Exception.Create(Format('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: @@ -1645,18 +2164,18 @@ begin assert(false); exit; end; - else raise Exception.Create('ketmar forgot to handle some field type'); + else raise TDynParseException.Create(pr, 'ketmar forgot to handle some field type'); end; - raise Exception.Create(Format('cannot parse field ''%s'' yet', [mName])); + raise TDynParseException.CreateFmt(pr, 'cannot parse field ''%s'' yet', [mName]); end; // ////////////////////////////////////////////////////////////////////////// // constructor TDynRecord.Create (pr: TTextParser); begin - if (pr = nil) then raise Exception.Create('cannot create record type without type definition'); + 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)} @@ -1674,7 +2193,7 @@ end; constructor TDynRecord.Create (); begin - mName := ''; + mTypeName := ''; mSize := 0; mFields := TDynFieldList.Create(); {$IF DEFINED(XDYNREC_USE_FIELDHASH)} @@ -1685,12 +2204,30 @@ begin mHeaderRec := nil; mTagInt := 0; mTagPtr := nil; + mRec2Free := nil; end; destructor TDynRecord.Destroy (); +var + fld: TDynField; + rec: TDynRecord; begin - mName := ''; + if (mRec2Free <> nil) then + begin + for rec in mRec2Free do + begin + if (rec <> self) then + begin + //writeln(formatstrf('freeing: 0x%08x; name=%s; id=%s', [Pointer(rec), rec.mName, rec.mId])); + rec.Free(); + end; + end; + mRec2Free.Free(); + mRec2Free := nil; + end; + mTypeName := ''; + for fld in mFields do fld.Free(); mFields.Free(); mFields := nil; {$IF DEFINED(XDYNREC_USE_FIELDHASH)} @@ -1705,9 +2242,19 @@ begin end; +procedure TDynRecord.regrec (rec: TDynRecord); +begin + if (rec <> nil) and (rec <> self) then + begin + if (mRec2Free = nil) then mRec2Free := TDynRecList.Create(); + mRec2Free.append(rec); + end; +end; + + procedure TDynRecord.addField (fld: TDynField); inline; begin - if (fld = nil) then raise Exception.Create('cannot append nil field to record'); + if (fld = nil) then raise TDynRecException.Create('cannot append nil field to record'); mFields.append(fld); {$IF DEFINED(XDYNREC_USE_FIELDHASH)} if (Length(fld.mName) > 0) then mFieldsHash.put(fld.mName, mFields.count-1); @@ -1718,7 +2265,7 @@ end; function TDynRecord.addFieldChecked (fld: TDynField): Boolean; inline; // `true`: duplicate name begin result := false; - if (fld = nil) then raise Exception.Create('cannot append nil field to record'); + if (fld = nil) then raise TDynRecException.Create('cannot append nil field to record'); {$IF not DEFINED(XDYNREC_USE_FIELDHASH)} if (Length(fld.mName) > 0) then result := hasByName(fld.mName); {$ENDIF} @@ -1800,7 +2347,7 @@ begin end; -function TDynRecord.clone (): TDynRecord; +function TDynRecord.clone (registerIn: TDynRecord): TDynRecord; var fld: TDynField; f: Integer; @@ -1808,21 +2355,23 @@ begin result := TDynRecord.Create(); result.mOwner := mOwner; result.mId := mId; - result.mPasName := mPasName; - result.mName := mName; + result.mTypeName := mTypeName; + result.mTip := mTip; + result.mHelp := mHelp; result.mSize := mSize; + result.mHeader := mHeader; + result.mBinBlock := mBinBlock; + result.mHeaderRec := mHeaderRec; + result.mTagInt := mTagInt; + result.mTagPtr := mTagPtr; if (mFields.count > 0) then begin result.mFields.capacity := mFields.count; - for fld in mFields do result.addField(fld.clone(result)); + for fld in mFields do result.addField(fld.clone(result, registerIn)); end; SetLength(result.mTrigTypes, Length(mTrigTypes)); for f := 0 to High(mTrigTypes) do result.mTrigTypes[f] := mTrigTypes[f]; - result.mHeader := mHeader; - result.mBinBlock := mBinBlock; - result.mHeaderRec := mHeaderRec; - result.mTagInt := mTagInt; - result.mTagPtr := mTagPtr; + if (registerIn <> nil) then registerIn.regrec(result); end; @@ -1836,7 +2385,7 @@ begin // find record data fld := mHeaderRec.field[atypename]; if (fld = nil) then exit; - if (fld.mType <> fld.TType.TList) then raise Exception.Create(Format('cannot get record of type ''%s'' due to name conflict with ordinary field', [atypename])); + if (fld.mType <> fld.TType.TList) then raise TDynRecException.CreateFmt('cannot get record of type ''%s'' due to name conflict with ordinary field', [atypename]); // find by id if (fld.mRVal <> nil) then begin @@ -1855,7 +2404,7 @@ begin // find record data fld := mHeaderRec.field[atypename]; if (fld = nil) then exit; - if (fld.mType <> fld.TType.TList) then raise Exception.Create(Format('cannot get record of type ''%s'' due to name conflict with ordinary field', [atypename])); + if (fld.mType <> fld.TType.TList) then raise TDynRecException.CreateFmt('cannot get record of type ''%s'' due to name conflict with ordinary field', [atypename]); // find by ref if (fld.mRVal <> nil) then begin @@ -1881,12 +2430,12 @@ begin fld.mOwner := mHeaderRec; mHeaderRec.addField(fld); end; - if (fld.mType <> fld.TType.TList) then raise Exception.Create(Format('cannot append record of type ''%s'' due to name conflict with ordinary field', [atypename])); + if (fld.mType <> fld.TType.TList) then raise TDynRecException.CreateFmt('cannot append record of type ''%s'' due to name conflict with ordinary field', [atypename]); // append if (fld.mRVal = nil) then begin fld.mRVal := TDynRecList.Create(); - fld.mRHash := hashNewStrInt(); + fld.mRHash := THashStrInt.Create(); end; result := fld.addListItem(rc); end; @@ -1919,94 +2468,115 @@ 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; // number of records of the given instance -function TDynRecord.instanceCount (const typename: AnsiString): Integer; +function TDynRecord.instanceCount (const atypename: AnsiString): Integer; var fld: TDynField; begin result := 0; - fld := field[typename]; + fld := field[atypename]; if (fld <> nil) and (fld.mType = fld.TType.TList) then result := fld.mRVal.count; end; -procedure TDynRecord.setUserField (const fldname: AnsiString; v: LongInt); +function TDynRecord.newTypedRecord (const atypename, aid: AnsiString): TDynRecord; var + trc: TDynRecord; fld: TDynField; begin - if (Length(fldname) = 0) then exit; - fld := field[fldname]; - if (fld <> nil) then - begin - if (fld.mType <> fld.TType.TInt) or (fld.mEBS <> fld.TEBS.TNone) then - begin - raise Exception.Create(Format('invalid user field ''%s'' type', [fld.name])); - end; - end - else + 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 := aid; + addRecordByType(atypename, result); +end; + + +procedure TDynRecord.clearRefRecs (rec: TDynRecord); + procedure clearRefs (fld: TDynField); + var + rc: TDynRecord; begin - fld := TDynField.Create(fldname, fld.TType.TInt); - fld.mOwner := self; - fld.mIVal := v; - fld.mInternal := true; - fld.mDefined := true; - addField(fld); + 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; -procedure TDynRecord.setUserField (const fldname: AnsiString; v: AnsiString); +// 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 - if (Length(fldname) = 0) then exit; - fld := field[fldname]; - if (fld <> nil) then + 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 (fld.mType <> fld.TType.TString) or (fld.mEBS <> fld.TEBS.TNone) then + if (mRec2Free[f] = rec) then begin - raise Exception.Create(Format('invalid user field ''%s'' type', [fld.name])); + mRec2Free[f] := nil; + doFree := true; end; - end - else - begin - fld := TDynField.Create(fldname, fld.TType.TString); - fld.mOwner := self; - fld.mSVal := v; - fld.mInternal := true; - fld.mDefined := true; - addField(fld); end; + if doFree then rec.Free(); end; -procedure TDynRecord.setUserField (const fldname: AnsiString; v: Boolean); +function TDynRecord.getUserVar (const aname: AnsiString): Variant; var fld: TDynField; begin - if (Length(fldname) = 0) then exit; - fld := field[fldname]; - if (fld <> nil) then - begin - if (fld.mType <> fld.TType.TBool) or (fld.mEBS <> fld.TEBS.TNone) then - begin - raise Exception.Create(Format('invalid user field ''%s'' type', [fld.name])); - end; - end - else + fld := getFieldByName(aname); + if (fld = nil) then result := Unassigned else result := fld.value; +end; + + +procedure TDynRecord.setUserVar (const aname: AnsiString; val: Variant); +var + fld: TDynField; +begin + fld := getFieldByName(aname); + if (fld = nil) then begin - fld := TDynField.Create(fldname, fld.TType.TBool); + if (Length(aname) = 0) then raise TDynRecException.Create('cannot create nameless user field'); + fld := TDynField.Create(aname, val); fld.mOwner := self; - fld.mIVal := Integer(v); fld.mInternal := true; - fld.mDefined := true; addField(fld); + end + else + begin + fld.value := val; end; end; @@ -2023,10 +2593,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 Exception.Create(Format('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; @@ -2037,74 +2607,59 @@ begin SetLength(mTrigTypes, 1); mTrigTypes[0] := tdn; end; - mName := 'TriggerData'; + mTypeName := 'TriggerData'; end else begin - mPasName := pr.expectId(); // pascal record name - pr.expectId('is'); - mName := pr.expectStr(); - 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 Exception.Create(Format('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 Exception.Create(Format('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 Exception.Create(Format('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 Exception.Create(Format('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); - //if hasByName(fld.name) then begin fld.Free(); raise Exception.Create(Format('duplicate field ''%s''', [fld.name])); end; // append fld.mOwner := self; if addFieldChecked(fld) then begin fld.Free(); - raise Exception.Create(Format('duplicate field ''%s''', [fld.name])); + raise TDynParseException.CreateFmt(pr, 'duplicate field ''%s''', [fld.name]); end; // done with field end; - pr.expectTT(pr.TTEnd); -end; - - -function TDynRecord.pasdef (): AnsiString; -var - fld: TDynField; -begin - if isTrigData then - begin - assert(false); - result := ''; - end - else - begin - // record - result := ' '+mPasName+' = packed record'#10; - end; - for fld in mFields do - begin - if fld.mInternal then continue; - if (fld.mBinOfs < 0) then continue; - result += ' '+fld.pasdef+#10; - end; - result += ' end;'#10; + pr.expectDelim('}'); end; @@ -2134,7 +2689,7 @@ begin else begin // record - result := mPasName+' is '+quoteStr(mName); + result := quoteStr(mTypeName); if (mSize >= 0) then result += Format(' size %d bytes', [mSize]); if mHeader then result += ' header'; end; @@ -2179,8 +2734,11 @@ 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); - //raise Exception.Create(Format('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])); + 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, ')'); fld.mRecRefId := ''; @@ -2189,7 +2747,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; @@ -2203,7 +2761,7 @@ begin // parse map file as sequence of blocks sign[0] := #4; st.ReadBuffer(sign[1], 4); - if (sign <> 'MAP'#1) then raise Exception.Create('invalid binary map signature'); + if (sign <> 'MAP'#1) then raise TDynRecException.Create('invalid binary map signature'); // parse blocks while (st.position < st.size) do begin @@ -2212,19 +2770,19 @@ begin readLongWord(st); // reserved bsize := readLongInt(st); {$IF DEFINED(D2D_XDYN_DEBUG)}writeln('btype=', btype, '; bsize=', bsize);{$ENDIF} - if (bsize < 0) or (bsize > $1fffffff) then raise Exception.Create(Format('block of type %d has invalid size %d', [btype, bsize])); - if loaded[btype] then raise Exception.Create(Format('block of type %d already loaded', [btype])); + if (bsize < 0) or (bsize > $1fffffff) then raise TDynRecException.CreateFmt('block of type %d has invalid size %d', [btype, bsize]); + if loaded[btype] then raise TDynRecException.CreateFmt('block of type %d already loaded', [btype]); loaded[btype] := true; // find record type for this block rect := nil; for rec in mOwner.recTypes do if (rec.mBinBlock = btype) then begin rect := rec; break; end; - if (rect = nil) then raise Exception.Create(Format('block of type %d has no corresponding record', [btype])); + if (rect = nil) then raise TDynRecException.CreateFmt('block of type %d has no corresponding record', [btype]); //writeln('found type ''', rec.mName, ''' for block type ', btype); - if (rec.mSize = 0) or ((bsize mod rec.mSize) <> 0) then raise Exception.Create(Format('block of type %d has invalid number of records', [btype])); + if (rec.mSize = 0) or ((bsize mod rec.mSize) <> 0) then raise TDynRecException.CreateFmt('block of type %d has invalid number of records', [btype]); // header? if (rect.mHeader) then begin - if (bsize <> mSize) then raise Exception.Create(Format('header block of type %d has invalid number of records', [btype])); + if (bsize <> mSize) then raise TDynRecException.CreateFmt('header block of type %d has invalid number of records', [btype]); GetMem(buf, bsize); st.ReadBuffer(buf^, bsize); mst.setup(buf, mSize); @@ -2233,7 +2791,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 @@ -2243,10 +2801,10 @@ begin for f := 0 to (bsize div rec.mSize)-1 do begin mst.setup(buf+f*rec.mSize, rec.mSize); - rec := rect.clone(); + 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; @@ -2266,19 +2824,25 @@ begin end; // read fields - if StrEqu(mName, 'TriggerData') then mSize := Integer(st.size-st.position); - if (mSize < 1) then raise Exception.Create(Format('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 begin if fld.mInternal then continue; if (fld.mBinOfs < 0) then continue; - if (fld.mBinOfs >= st.size) then raise Exception.Create(Format('record of type ''%s'' has invalid field ''%s''', [fld.mName])); + if (fld.mBinOfs >= st.size) then raise TDynRecException.CreateFmt('record of type ''%s'' has invalid field ''%s''', [fld.mName]); mst.setup(buf+fld.mBinOfs, mSize-fld.mBinOfs); //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); @@ -2286,21 +2850,20 @@ 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 if (trigbufsz < 0) then begin - if (mBinBlock < 1) then raise Exception.Create('cannot write binary record without block number'); - if (mSize < 1) then raise Exception.Create('cannot write binary record without size'); + if (mBinBlock < 1) then raise TDynRecException.Create('cannot write binary record without block number'); + if (mSize < 1) then raise TDynRecException.Create('cannot write binary record without size'); bufsz := mSize; end else @@ -2318,11 +2881,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 >= bufsz) then raise Exception.Create('binary value offset is outside of the buffer'); + 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 @@ -2351,7 +2918,7 @@ begin if (fld.mType = fld.TType.TList) then begin if (fld.mRVal = nil) or (fld.mRVal.count = 0) then continue; - rec := mOwner.findRecType(fld.mName); + rec := mOwner.recType[fld.mName]; if (rec = nil) then continue; if (rec.mBinBlock <= 0) then continue; if (blkmax < rec.mBinBlock) then blkmax := rec.mBinBlock; @@ -2368,11 +2935,11 @@ begin if (fld.mType = fld.TType.TList) then begin if (fld.mRVal = nil) or (fld.mRVal.count = 0) then continue; - rec := mOwner.findRecType(fld.mName); + rec := mOwner.recType[fld.mName]; 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 @@ -2404,10 +2971,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; @@ -2419,12 +2988,32 @@ begin // record list? if (fld.mType = fld.TType.TList) then begin - if not mHeader then raise Exception.Create('record list in non-header record'); - if (fld.mRVal <> nil) then + if not mHeader then raise TDynRecException.Create('record list in non-header record'); + 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; @@ -2432,7 +3021,7 @@ begin continue; end; if fld.mInternal then continue; - if fld.mOmitDef and fld.isDefaultValue then continue; + if (not fld.mWriteDef) and fld.isDefaultValue then continue; wr.putIndent(); fld.writeTo(wr); end; @@ -2478,10 +3067,49 @@ var {$IF DEFINED(D2D_DYNREC_PROFILER)} stt, stall: UInt64; {$ENDIF} + + procedure linkNames (rec: TDynRecord); + var + fld: TDynField; + 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); + continue; + end; + if (Length(fld.mRecRefId) = 0) then continue; + assert(fld.mEBSType <> nil); + 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); + 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 := ''; + fld.mRecRef := rt; + fld.mDefined := true; + end; + for fld in rec.mFields do + begin + //writeln(' ', fld.mName); + fld.fixDefaultValue(); + end; + end; + begin - if (mOwner = nil) then raise Exception.Create(Format('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 @@ -2495,82 +3123,68 @@ 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 Exception.Create('identifier expected'); + if (pr.tokType <> pr.TTId) then raise TDynParseException.Create(pr, 'identifier expected'); //writeln('<', mName, '.', pr.tokStr, '>'); // records if mHeader then begin // add records with this type (if any) - {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF} - trc := mOwner.findRecType(pr.tokStr); - {$IF DEFINED(D2D_DYNREC_PROFILER)}profFindRecType := curTimeMicro()-stt;{$ENDIF} + {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := getTimeMicro();{$ENDIF} + trc := mOwner.recType[pr.tokStr]; + {$IF DEFINED(D2D_DYNREC_PROFILER)}profFindRecType := getTimeMicro()-stt;{$ENDIF} if (trc <> nil) then begin - {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF} - rec := trc.clone(); - {$IF DEFINED(D2D_DYNREC_PROFILER)}profCloneRec := curTimeMicro()-stt;{$ENDIF} + {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := getTimeMicro();{$ENDIF} + rec := trc.clone(mHeaderRec); + {$IF DEFINED(D2D_DYNREC_PROFILER)}profCloneRec := getTimeMicro()-stt;{$ENDIF} rec.mHeaderRec := mHeaderRec; - try - pr.skipToken(); - rec.parseValue(pr); - (* - if (Length(rec.mId) > 0) then - begin - {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF} - fld := field[pr.tokStr]; - {$IF DEFINED(D2D_DYNREC_PROFILER)}profFieldSearching := curTimeMicro()-stt;{$ENDIF} - (* - if (fld <> nil) and (fld.mRVal <> nil) then - begin - {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF} - //idtmp := trc.mName+':'+rec.mId; - //if ids.put(idtmp, 1) then raise Exception.Create(Format('duplicate thing ''%s'' in record ''%s''', [fld.mName, mName])); - if fld.mRHash.has(rec.mId) then raise Exception.Create(Format('duplicate thing ''%s'' in record ''%s''', [fld.mName, mName])); - {$IF DEFINED(D2D_DYNREC_PROFILER)}profListDupChecking := curTimeMicro()-stt;{$ENDIF} - end; - end; - *) - {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF} - addRecordByType(rec.mName, rec); - {$IF DEFINED(D2D_DYNREC_PROFILER)}profAddRecByType := curTimeMicro()-stt;{$ENDIF} - rec := nil; - finally - rec.Free(); - end; + // on error, it will be freed by memowner + pr.skipToken(); + rec.parseValue(pr); + {$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]; - {$IF DEFINED(D2D_DYNREC_PROFILER)}profFieldSearching := curTimeMicro()-stt;{$ENDIF} + //writeln('1: <', mName, '.', pr.tokStr, '>'); + {$IF DEFINED(D2D_DYNREC_PROFILER)}profFieldSearching := getTimeMicro()-stt;{$ENDIF} if (fld <> nil) then begin - if fld.defined then raise Exception.Create(Format('duplicate field ''%s'' in record ''%s''', [fld.mName, mName])); - if fld.internal then raise Exception.Create(Format('internal field ''%s'' in record ''%s''', [fld.mName, mName])); - pr.skipToken(); - {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF} + //writeln('2: <', mName, '.', pr.tokStr, '>'); + 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 := 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 Exception.Create(Format('unknown field ''%s'' in record ''%s''', [pr.tokStr, mName])); + raise TDynParseException.CreateFmt(pr, 'unknown field ''%s'' in record ''%s''', [pr.tokStr, mTypeName]); + end; + pr.expectDelim('}'); + + if mHeader then + begin + // link fields + linkNames(self); + for rec in mRec2Free do if (rec <> nil) then linkNames(rec); end; - pr.expectTT(pr.TTEnd); - // 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; @@ -2592,7 +3206,9 @@ end; procedure TDynEBS.cleanup (); begin mIsEnum := false; - mName := ''; + mTypeName := ''; + mTip := ''; + mHelp := ''; mIds := nil; mVals := nil; mMaxName := ''; @@ -2632,7 +3248,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; @@ -2662,7 +3278,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 @@ -2694,18 +3310,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 Exception.Create(Format('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 Exception.Create(Format('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; @@ -2714,7 +3346,7 @@ begin begin if pr.eatId('MAX') then begin - if (Length(mMaxName) > 0) then raise Exception.Create(Format('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 @@ -2743,11 +3375,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 @@ -2774,6 +3406,7 @@ var rec: TDynRecord; ebs: TDynEBS; begin + //!!!FIXME!!! check who owns trigs and recs! for rec in recTypes do rec.Free(); for rec in trigTypes do rec.Free(); for ebs in ebsTypes do ebs.Free(); @@ -2789,7 +3422,7 @@ end; function TDynMapDef.getHeaderRecType (): TDynRecord; inline; begin - if (recTypes.count = 0) then raise Exception.Create('no header in empty mapdef'); + if (recTypes.count = 0) then raise TDynRecException.Create('no header in empty mapdef'); result := recTypes[0]; end; @@ -2800,7 +3433,7 @@ var begin for rec in recTypes do begin - if StrEqu(rec.name, aname) then begin result := rec; exit; end; + if StrEqu(rec.typeName, aname) then begin result := rec; exit; end; end; result := nil; end; @@ -2824,7 +3457,7 @@ var begin for ebs in ebsTypes do begin - if StrEqu(ebs.name, aname) then begin result := ebs; exit; end; + if StrEqu(ebs.typeName, aname) then begin result := ebs; exit; end; end; result := nil; end; @@ -2850,14 +3483,14 @@ var TDynField.TEBS.TRec: begin fld.mEBSType := findRecType(fld.mEBSTypeName); - if (fld.mEBSType = nil) then raise Exception.Create(Format('field ''%s'' of type ''%s'' has no correcponding record definition', [fld.mName, fld.mEBSTypeName])); + if (fld.mEBSType = nil) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' of type ''%s'' has no correcponding record definition', [fld.mName, fld.mEBSTypeName]); end; TDynField.TEBS.TEnum, TDynField.TEBS.TBitSet: begin fld.mEBSType := findEBSType(fld.mEBSTypeName); - if (fld.mEBSType = nil) then raise Exception.Create(Format('field ''%s'' of type ''%s'' has no correcponding enum/bitset', [fld.mName, fld.mEBSTypeName])); - if ((fld.mEBS = TDynField.TEBS.TEnum) <> (fld.mEBSType as TDynEBS).mIsEnum) then raise Exception.Create(Format('field ''%s'' of type ''%s'' enum/bitset type conflict', [fld.mName, fld.mEBSTypeName])); + if (fld.mEBSType = nil) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' of type ''%s'' has no correcponding enum/bitset', [fld.mName, fld.mEBSTypeName]); + if ((fld.mEBS = TDynField.TEBS.TEnum) <> (fld.mEBSType as TDynEBS).mIsEnum) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' of type ''%s'' enum/bitset type conflict', [fld.mName, fld.mEBSTypeName]); end; end; end; @@ -2876,47 +3509,51 @@ begin while true do begin if not pr.skipBlanks() then break; - if (pr.tokType <> pr.TTId) then raise Exception.Create('identifier expected'); - if (pr.tokStr = 'enum') or (pr.tokStr = 'bitset') then + if (pr.tokType = pr.TTId) then begin - eb := TDynEBS.Create(pr); - if (findEBSType(eb.name) <> nil) then + // enum or bitset + if (pr.tokStr = 'enum') or (pr.tokStr = 'bitset') then begin - eb.Free(); - raise Exception.Create(Format('duplicate enum/bitset ''%s''', [eb.name])); + eb := TDynEBS.Create(pr); + if (findEBSType(eb.typeName) <> nil) then + begin + eb.Free(); + raise TDynParseException.CreateFmt(pr, 'duplicate enum/bitset ''%s''', [eb.typeName]); + end; + eb.mOwner := self; + ebsTypes.append(eb); + //writeln(eb.definition); writeln; + continue; end; - eb.mOwner := self; - ebsTypes.append(eb); - //writeln(eb.definition); writeln; - continue; - end; - if (pr.tokStr = 'TriggerData') then - begin - rec := TDynRecord.Create(pr); - for f := 0 to High(rec.mTrigTypes) do + // triggerdata + if (pr.tokStr = 'TriggerData') then begin - if (findTrigFor(rec.mTrigTypes[f]) <> nil) then + rec := TDynRecord.Create(pr); + for f := 0 to High(rec.mTrigTypes) do begin - rec.Free(); - raise Exception.Create(Format('duplicate trigdata ''%s''', [rec.mTrigTypes[f]])); + if (findTrigFor(rec.mTrigTypes[f]) <> nil) then + begin + rec.Free(); + raise TDynParseException.CreateFmt(pr, 'duplicate trigdata ''%s''', [rec.mTrigTypes[f]]); + end; end; + rec.mOwner := self; + trigTypes.append(rec); + //writeln(dr.definition); writeln; + continue; end; - rec.mOwner := self; - trigTypes.append(rec); - //writeln(dr.definition); writeln; - continue; end; rec := TDynRecord.Create(pr); //writeln(dr.definition); writeln; - if (findRecType(rec.name) <> nil) then begin rec.Free(); raise Exception.Create(Format('duplicate record ''%s''', [rec.name])); end; - if (hdr <> nil) and StrEqu(rec.name, hdr.name) then begin rec.Free(); raise Exception.Create(Format('duplicate record ''%s''', [rec.name])); end; + if (findRecType(rec.typeName) <> nil) then begin rec.Free(); raise TDynParseException.CreateFmt(pr, 'duplicate record ''%s''', [rec.typeName]); end; + if (hdr <> nil) and StrEqu(rec.typeName, hdr.typeName) then begin rec.Free(); raise TDynParseException.CreateFmt(pr, 'duplicate record ''%s''', [rec.typeName]); end; rec.mOwner := self; if rec.mHeader then begin - if (hdr <> nil) then begin rec.Free(); raise Exception.Create(Format('duplicate header record ''%s'' (previous is ''%s'')', [rec.name, hdr.name])); end; + if (hdr <> nil) then begin rec.Free(); raise TDynParseException.CreateFmt(pr, 'duplicate header record ''%s'' (previous is ''%s'')', [rec.typeName, hdr.typeName]); end; hdr := rec; end else @@ -2926,7 +3563,7 @@ begin end; // put header record to top - if (hdr = nil) then raise Exception.Create('header definition not found in mapdef'); + if (hdr = nil) then raise TDynParseException.Create(pr, 'header definition not found in mapdef'); recTypes.append(nil); for f := recTypes.count-1 downto 1 do recTypes[f] := recTypes[f-1]; recTypes[0] := hdr; @@ -2942,14 +3579,14 @@ end; // ////////////////////////////////////////////////////////////////////////// // -function TDynMapDef.parseMap (pr: TTextParser): TDynRecord; +function TDynMapDef.parseTextMap (pr: TTextParser): TDynRecord; var res: TDynRecord = nil; begin result := nil; try - pr.expectId(headerType.name); - res := headerType.clone(); + pr.expectId(headerType.typeName); + res := headerType.clone(nil); res.mHeaderRec := res; res.parseValue(pr); result := res; @@ -2966,7 +3603,7 @@ var begin result := nil; try - res := headerType.clone(); + res := headerType.clone(nil); res.mHeaderRec := res; res.parseBinValue(st); result := res; @@ -2977,50 +3614,65 @@ begin end; -function TDynMapDef.pasdef (): AnsiString; +// WARNING! stream must be seekable +function TDynMapDef.parseMap (st: TStream; wasBinary: PBoolean=nil): TDynRecord; var - ebs: TDynEBS; - rec: TDynRecord; - fld: TDynField; - needComma: Boolean; - tn: AnsiString; -begin - result := ''; - result += '// ////////////////////////////////////////////////////////////////////////// //'#10; - result += '// enums and bitsets'#10; - for ebs in ebsTypes do result += #10+ebs.pasdef(); - result += #10#10'// ////////////////////////////////////////////////////////////////////////// //'#10; - result += '// records'#10'type'#10; - for rec in recTypes do - begin - if (rec.mSize < 1) then continue; - result += rec.pasdef(); - result += #10; - end; - result += #10#10'// ////////////////////////////////////////////////////////////////////////// //'#10; - result += '// triggerdata'#10'type'#10; - result += ' TTriggerData = record'#10; - result += ' case Byte of'#10; - result += ' 0: (Default: Byte128);'#10; - for rec in trigTypes do + 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; + if (sign[0] = 'M') and (sign[1] = 'A') and (sign[2] = 'P') then begin - result += ' '; - needComma := false; - for tn in rec.mTrigTypes do + if (sign[3] = #1) then begin - if needComma then result += ', ' else needComma := true; - result += tn; + if (wasBinary <> nil) then wasBinary^ := true; + result := parseBinMap(st); + exit; end; - result += ': ('#10; - for fld in rec.mFields do - begin - if fld.mInternal then continue; - if (fld.mBinOfs < 0) then continue; - result += ' '+fld.pasdef+#10; + raise TDynRecException.Create('invalid binary map version'); + end + else + begin + pr := TFileTextParser.Create(st, false); // `st` is not owned + try + try + result := parseTextMap(pr); + except on e: Exception do + raise TDynParseException.Create(pr, e.message); + end; + finally + pr.Free(); end; - result += ' );'#10; end; - result += ' end;'#10; +end; + + +// returns `true` if the given stream can be a map file +// stream position is 0 on return +// WARNING! stream must be seekable +class function TDynMapDef.canBeMap (st: TStream): Boolean; +var + sign: packed array[0..3] of AnsiChar; + pr: TTextParser; +begin + result := false; + st.position := 0; + st.ReadBuffer(sign[0], 4); + if (sign[0] = 'M') and (sign[1] = 'A') and (sign[2] = 'P') then + begin + result := (sign[3] = #1); + end + else + begin + st.position := 0; + pr := TFileTextParser.Create(st, false); // `st` is not owned + result := (pr.tokType = pr.TTId) and (pr.tokStr = 'map'); + pr.Free(); + end; + st.position := 0; end; @@ -3035,6 +3687,12 @@ begin end; +function TDynMapDef.getRecTypeCount (): Integer; inline; begin result := recTypes.count; end; +function TDynMapDef.getRecTypeAt (idx: Integer): TDynRecord; inline; begin if (idx >= 0) and (idx < recTypes.count) then result := recTypes[idx] else result := nil; end; + +function TDynMapDef.getEBSTypeCount (): Integer; inline; begin result := ebsTypes.count; end; +function TDynMapDef.getEBSTypeAt (idx: Integer): TDynEBS; inline; begin if (idx >= 0) and (idx < ebsTypes.count) then result := ebsTypes[idx] else result := nil; end; + function TDynMapDef.getTrigTypeCount (): Integer; inline; begin result := trigTypes.count; end; function TDynMapDef.getTrigTypeAt (idx: Integer): TDynRecord; inline; begin if (idx >= 0) and (idx < trigTypes.count) then result := trigTypes[idx] else result := nil; end;