src/shared/xdynrec.pas

   1 (* Copyright (C)  DooM 2D:Forever Developers
   2  *
   3  * This program is free software: you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation, either version 3 of the License, or
   6  * (at your option) any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15  *)
  16 {$INCLUDE a_modes.inc}
  17 {.$DEFINE XDYNREC_USE_FIELDHASH} // actually, it is SLOWER with this
  18 unit xdynrec;
  19
  20 interface
  21
  22 uses
  23   SysUtils, Variants, Classes,
  24   xparser, xstreams, utils, hashtable;
  25
  26
  27 // ////////////////////////////////////////////////////////////////////////// //
  28 type
  29   TDynRecException = class(Exception)
  30   public
  31     constructor Create (const amsg: AnsiString);
  32     constructor CreateFmt (const afmt: AnsiString; const args: array of const);
  33   end;
  34
  35   TDynParseException = class(TDynRecException)
  36   public
  37     tokLine, tokCol: Integer;
  38
  39   public
  40     constructor Create (pr: TTextParser; const amsg: AnsiString);
  41     constructor CreateFmt (pr: TTextParser; const afmt: AnsiString; const args: array of const);
  42   end;
  43
  44
  45 // ////////////////////////////////////////////////////////////////////////// //
  46 type
  47   TDynMapDef = class;
  48   TDynRecord = class;
  49   TDynField = class;
  50   TDynEBS = class;
  51
  52   TDynFieldList = specialize TSimpleList<TDynField>;
  53   TDynRecList = specialize TSimpleList<TDynRecord>;
  54   TDynEBSList = specialize TSimpleList<TDynEBS>;
  55
  56   // this is base type for all scalars (and arrays)
  57   TDynField = class
  58   public
  59     type
  60       TType = (TBool, TChar, TByte, TUByte, TShort, TUShort, TInt, TUInt, TString, TPoint, TSize, TList, TTrigData);
  61       // TPoint: pair of Integers
  62       // TSize: pair of UShorts
  63       // TList: actually, array of records
  64       // TTrigData: array of mMaxDim bytes, but internally a record (mRecRef)
  65       // in binary: arrays of chars are pascal shortstrings (with counter in the first byte)
  66
  67   private
  68     type
  69       TEBS = (TNone, TRec, TEnum, TBitSet);
  70
  71   private
  72     mOwner: TDynRecord; // owner record
  73     mName: AnsiString; // field name
  74     mType: TType; // field type
  75     mIVal: Integer; // for all integer types
  76     mIVal2: Integer; // for point and size
  77     mSVal: AnsiString; // string; for byte and char arrays
  78     mRVal: TDynRecList; // for list
  79     mRHash: THashStrInt; // id -> index in mRVal
  80     mRecRef: TDynRecord; // for TEBS.TRec
  81     mMaxDim: Integer; // for byte and char arrays; <0: not an array; 0: impossible value
  82     mBinOfs: Integer; // offset in binary; <0 - none
  83     mSepPosSize: Boolean; // for points and sizes, use separate fields
  84     mAsT: Boolean; // for points and sizes, use separate fields, names starts with `t`
  85     mDefined: Boolean;
  86     mHasDefault: Boolean;
  87     mWriteDef: Boolean;
  88     mInternal: Boolean;
  89     mNegBool: Boolean;
  90     mBitSetUnique: Boolean; // bitset can contain only one value
  91     mAsMonsterId: Boolean; // special hack for triggers: monster record number+1 in binary (so 0 means "none")
  92     // default value
  93     mDefUnparsed: AnsiString;
  94     mDefSVal: AnsiString; // default string value
  95     mDefIVal, mDefIVal2: Integer; // default integer values
  96     mDefRecRef: TDynRecord;
  97     mEBS: TEBS; // complex type type
  98     mEBSTypeName: AnsiString; // name of enum, bitset or record
  99     mEBSType: TObject; // either TDynRecord or TDynEBS; nil means "simple type"; nil for `TTrigData` too
 100
 101     // for binary parser
 102     mRecRefId: AnsiString;
 103
 104     // for userdata
 105     mTagInt: Integer;
 106     mTagPtr: Pointer;
 107
 108     // for pasgen
 109     mAlias: AnsiString;
 110
 111   private
 112     procedure cleanup ();
 113
 114     procedure parseDefaultValue (); // parse `mDefUnparsed` to `mDefSVal`, `mDefIVal`, `mDefIVal2`, `mDefRecRef`
 115     procedure fixDefaultValue (); // this will NOT clone `mDefRecRef`
 116     function isDefaultValue (): Boolean;
 117
 118     function getListCount (): Integer; inline;
 119     function getListItem (idx: Integer): TDynRecord; inline; overload;
 120     function getListItem (const aname: AnsiString): TDynRecord; inline; overload;
 121
 122     function getRecRefIndex (): Integer;
 123
 124     function getVar (): Variant;
 125     procedure setVar (val: Variant);
 126
 127     procedure setRecRef (arec: TDynRecord);
 128
 129     procedure parseDef (pr: TTextParser); // parse mapdef definition
 130     function definition (): AnsiString; // generate mapdef definition
 131
 132   protected
 133     // returns `true` for duplicate record id
 134     function addListItem (rec: TDynRecord): Boolean; inline;
 135     function removeListItem (const aid: AnsiString): TDynRecord; // returns nil or removed record
 136
 137   public
 138     // get string name for the given type
 139     class function getTypeName (t: TType): AnsiString;
 140
 141   public
 142     constructor Create (const aname: AnsiString; atype: TType);
 143     constructor Create (const aname: AnsiString; val: Variant);
 144     constructor Create (pr: TTextParser);
 145     destructor Destroy (); override;
 146
 147     // clone this field; register all list records in `registerIn`
 148     // "registration" is required to manage record lifetime; use header record if in doubt
 149     // owner will be set to `newOwner`, if it is not `nil`, or to `owner`
 150     // for lists, cloning will clone all list members
 151     function clone (newOwner: TDynRecord=nil; registerIn: TDynRecord=nil): TDynField;
 152
 153     // compare field values (including trigdata)
 154     // WARNING: won't work for lists
 155     function isSimpleEqu (fld: TDynField): Boolean;
 156
 157     // parse string value to appropriate type and set new field value
 158     procedure setValue (const s: AnsiString);
 159
 160     // supports `for rec in field do` (for lists)
 161     function GetEnumerator (): TDynRecList.TEnumerator; inline;
 162
 163   public
 164     // text parser and writer
 165     procedure parseValue (pr: TTextParser);
 166     procedure writeTo (wr: TTextWriter);
 167
 168     // binary parser and writer (DO NOT USE!)
 169     procedure parseBinValue (st: TStream);
 170     procedure writeBinTo (st: TStream);
 171
 172   public
 173     // the following functions are here only for 'mapgen'! DO NOT USE!
 174     // build "alias name" for pascal code
 175     function palias (firstUp: Boolean=false): AnsiString;
 176
 177   public
 178     property owner: TDynRecord read mOwner;
 179     property name: AnsiString read mName; // field name
 180     property baseType: TType read mType; // field type (base for arrays)
 181     property defined: Boolean read mDefined; // was field value set to something by external code?
 182     property internal: Boolean read mInternal write mInternal; // internal field?
 183     property ival: Integer read mIVal; // integer value for int field (for speed), first field (x/w) for `TPoint` and `TSize`
 184     property ival2: Integer read mIVal2; // for `TPoint` and `TSize`, this is second field (y/h)
 185     property sval: AnsiString read mSVal; // string value for string field (for speed)
 186     property hasDefault: Boolean read mHasDefault; // `true` if this field has default value in mapdef
 187     property defsval: AnsiString read mDefSVal; // string representation of default value
 188     property ebs: TEBS read mEBS; // what kind of reference is this? none, enum, bitset, record
 189     property ebstype: TObject read mEBSType; // reference type (nil, TDynRecord, TDynEBS); WARNING: don't modify type!
 190     property ebstypename: AnsiString read mEBSTypeName; // enum/bitset name
 191     property recref: TDynRecord read mRecRef write setRecRef; // referenced record (actual one, you can modify it)
 192     property recrefIndex: Integer read getRecRefIndex; // index of referenced record in header; -1: not found
 193     // for record lists
 194     property count: Integer read getListCount;
 195     property itemAt[idx: Integer]: TDynRecord read getListItem;
 196     property item[const aname: AnsiString]: TDynRecord read getListItem; default; // alas, FPC 3+ lost property overloading feature
 197     // field value as Variant
 198     property value: Variant read getVar write setVar;
 199
 200   public
 201     // userdata (you can use these properties as you want to; they won't be written or read to files)
 202     property tagInt: Integer read mTagInt write mTagInt;
 203     property tagPtr: Pointer read mTagPtr write mTagPtr;
 204
 205   public
 206     // the following properties are here only for 'mapgen'! DO NOT USE!
 207     property negbool: Boolean read mNegBool;
 208     property hasTPrefix: Boolean read mAsT;
 209     property separatePasFields: Boolean read mSepPosSize;
 210     property binOfs: Integer read mBinOfs;
 211   end;
 212
 213
 214   // record, either with actual values, or with type definitions
 215   TDynRecord = class
 216   private
 217     mOwner: TDynMapDef;
 218     mId: AnsiString;
 219     mTypeName: AnsiString;
 220     mSize: Integer;
 221     mFields: TDynFieldList;
 222     {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
 223     mFieldsHash: THashStrInt; // id -> index in mRVal
 224     {$ENDIF}
 225     mTrigTypes: array of AnsiString; // if this is triggerdata, we'll hold list of triggers here
 226     mHeader: Boolean; // true for header record
 227     mBinBlock: Integer; // -1: none
 228     mHeaderRec: TDynRecord; // for "value" records this is header record with data, for "type" records this is header type record
 229
 230     // for userdata
 231     mTagInt: Integer;
 232     mTagPtr: Pointer;
 233
 234     mRec2Free: TDynRecList;
 235
 236   private
 237     procedure parseDef (pr: TTextParser); // parse definition
 238     function definition (): AnsiString;
 239
 240     function findByName (const aname: AnsiString): Integer; inline;
 241     function hasByName (const aname: AnsiString): Boolean; inline;
 242     function getFieldByName (const aname: AnsiString): TDynField; inline;
 243     function getFieldAt (idx: Integer): TDynField; inline;
 244     function getCount (): Integer; inline;
 245
 246     function getIsTrigData (): Boolean; inline;
 247     function getIsForTrig (const aname: AnsiString): Boolean; inline;
 248
 249     function getForTrigCount (): Integer; inline;
 250     function getForTrigAt (idx: Integer): AnsiString; inline;
 251
 252     procedure regrec (rec: TDynRecord);
 253
 254     function getUserVar (const aname: AnsiString): Variant;
 255     procedure setUserVar (const aname: AnsiString; val: Variant);
 256
 257     procedure clearRefRecs (rec: TDynRecord);
 258
 259   protected
 260     function findRecordByTypeId (const atypename, aid: AnsiString): TDynRecord;
 261     function findRecordNumByType (const atypename: AnsiString; rc: TDynRecord): Integer;
 262     function addRecordByType (const atypename: AnsiString; rc: TDynRecord): Boolean; // `true`: duplicate record id
 263
 264     procedure addField (fld: TDynField); inline;
 265     function addFieldChecked (fld: TDynField): Boolean; inline; // `true`: duplicate name
 266
 267   public
 268     constructor Create ();
 269     constructor Create (pr: TTextParser); // parse definition
 270     destructor Destroy (); override;
 271
 272     // clone this record; register all list records in `registerIn`
 273     // "registration" is required to manage record lifetime; use header record if in doubt
 274     // all fields are cloned too
 275     function clone (registerIn: TDynRecord): TDynRecord;
 276
 277     // compare records (values of all fields, including trigdata)
 278     // WARNING: won't work for records with list fields
 279     function isSimpleEqu (rec: TDynRecord): Boolean;
 280
 281     // find field with `TriggerType` type
 282     function trigTypeField (): TDynField;
 283
 284     // number of records of the given instance
 285     function instanceCount (const atypename: AnsiString): Integer;
 286
 287     // only for headers: create new record with the given type
 288     // will return cloned record ready for use, or `nil` on unknown type name
 289     // `aid` must not be empty, and must be unique
 290     function newTypedRecord (const atypename, aid: AnsiString): TDynRecord;
 291
 292     // remove record with the given type and id
 293     // return `true` if record was successfully found and removed
 294     // this will do all necessary recref cleanup too
 295     // WARNING: not tested yet
 296     function removeTypedRecord (const atypename, aid: AnsiString): Boolean;
 297
 298     //TODO:
 299     //  [.] API to create triggers
 300     //  [.] API to properly remove triggers (remove trigdata)
 301     //  [.] check if `removeTypedRecord()` does the right thing with inline records
 302     //  [.] for fields: assigning `recref` should remove previously assigned inline record (record without id)
 303     //  [.] other API i forgot
 304
 305   public
 306     // text parser
 307     // `beginEaten`: `true` if "{" was eaten
 308     procedure parseValue (pr: TTextParser; beginEaten: Boolean=false);
 309
 310     // text writer
 311     // `putHeader`: `true` to write complete header, otherwise only "{...}"
 312     procedure writeTo (wr: TTextWriter; putHeader: Boolean=true);
 313
 314     // binary parser and writer (DO NOT USE!)
 315     procedure parseBinValue (st: TStream; forceData: Boolean=false);
 316     procedure writeBinTo (st: TStream; trigbufsz: Integer=-1; onlyFields: Boolean=false);
 317
 318   public
 319     property mapdef: TDynMapDef read mOwner;
 320     property id: AnsiString read mId; // record id in text map
 321     property typeName: AnsiString read mTypeName; // record type name (like "panel", or "trigger")
 322     property has[const aname: AnsiString]: Boolean read hasByName; // do we have field with the given name?
 323     property count: Integer read getCount; // number of fields in this record
 324     property field[const aname: AnsiString]: TDynField read getFieldByName; default; // get field by name
 325     property fieldAt[idx: Integer]: TDynField read getFieldAt; // get field at the given index
 326     property isTrigData: Boolean read getIsTrigData; // is this special "TriggerData" record?
 327     property isForTrig[const aname: AnsiString]: Boolean read getIsForTrig; // can this "TriggerData" be used for the trigger with the given type?
 328     property forTrigCount: Integer read getForTrigCount; // number of trigger type names for "TriggerData"
 329     property forTrigAt[idx: Integer]: AnsiString read getForTrigAt; // trigger type name at the given index for "TriggerData"
 330     property headerRec: TDynRecord read mHeaderRec; // get header record for this one (header contains all other records, enums, bitsets, etc.)
 331     property isHeader: Boolean read mHeader; // is this a header record?
 332
 333   public
 334     // user fields; user can add arbitrary custom fields
 335     // by default, any user field will be marked as "internal"
 336     // note: you can use this to manipulate non-user fields too
 337     property user[const aname: AnsiString]: Variant read getUserVar write setUserVar;
 338
 339   public
 340     // userdata (you can use these properties as you want to; they won't be written or read to files)
 341     property tagInt: Integer read mTagInt write mTagInt;
 342     property tagPtr: Pointer read mTagPtr write mTagPtr;
 343   end;
 344
 345
 346   // bitset/enum definition
 347   TDynEBS = class
 348   private
 349     mOwner: TDynMapDef;
 350     mIsEnum: Boolean;
 351     mTypeName: AnsiString;
 352     mIds: array of AnsiString;
 353     mVals: array of Integer;
 354     mMaxName: AnsiString; // MAX field
 355     mMaxVal: Integer; // max value
 356
 357   private
 358     procedure cleanup ();
 359
 360     procedure parseDef (pr: TTextParser); // parse definition
 361
 362     function findByName (const aname: AnsiString): Integer; inline;
 363     function hasByName (const aname: AnsiString): Boolean; inline;
 364     function getFieldByName (const aname: AnsiString): Integer; inline;
 365
 366     function definition (): AnsiString;
 367     function pasdef (): AnsiString;
 368
 369   public
 370     constructor Create (pr: TTextParser); // parse definition
 371     destructor Destroy (); override;
 372
 373     // find name for the given value
 374     // return empty string if not found
 375     function nameByValue (v: Integer): AnsiString;
 376
 377   public
 378     property mapdef: TDynMapDef read mOwner;
 379     property typeName: AnsiString read mTypeName; // enum/bitset type name
 380     property isEnum: Boolean read mIsEnum; // is this enum? `false` means "bitset"
 381     property has[const aname: AnsiString]: Boolean read hasByName;
 382     property field[const aname: AnsiString]: Integer read getFieldByName;
 383   end;
 384
 385
 386   // parsed "mapdef.txt"
 387   TDynMapDef = class
 388   public
 389     recTypes: TDynRecList; // [0] is always header
 390     trigTypes: TDynRecList; // trigdata
 391     ebsTypes: TDynEBSList; // enums, bitsets
 392
 393   private
 394     procedure parseDef (pr: TTextParser);
 395
 396     function getHeaderRecType (): TDynRecord; inline;
 397
 398     function getRecTypeCount (): Integer; inline;
 399     function getRecTypeAt (idx: Integer): TDynRecord; inline;
 400
 401     function getEBSTypeCount (): Integer; inline;
 402     function getEBSTypeAt (idx: Integer): TDynEBS; inline;
 403
 404     function getTrigTypeCount (): Integer; inline;
 405     function getTrigTypeAt (idx: Integer): TDynRecord; inline;
 406
 407     // creates new header record
 408     function parseTextMap (pr: TTextParser): TDynRecord;
 409
 410     // creates new header record
 411     function parseBinMap (st: TStream): TDynRecord;
 412
 413   public
 414     constructor Create (pr: TTextParser); // parses data definition
 415     destructor Destroy (); override;
 416
 417     function findRecType (const aname: AnsiString): TDynRecord;
 418     function findTrigFor (const aname: AnsiString): TDynRecord;
 419     function findEBSType (const aname: AnsiString): TDynEBS;
 420
 421   public
 422     // parse text or binary map, return new header record
 423     // WARNING! stream must be seekable
 424     function parseMap (st: TStream): TDynRecord;
 425
 426     // returns `true` if the given stream can be a map file
 427     // stream position is 0 on return
 428     // WARNING! stream must be seekable
 429     class function canBeMap (st: TStream): Boolean;
 430
 431   public
 432     // the following functions are here only for 'mapgen'! DO NOT USE!
 433     function pasdefconst (): AnsiString;
 434
 435   public
 436     property headerType: TDynRecord read getHeaderRecType;
 437     // for record types
 438     property recTypeCount: Integer read getRecTypeCount;
 439     property recTypeAt[idx: Integer]: TDynRecord read getRecTypeAt;
 440     property recType[const aname: AnsiString]: TDynRecord read findRecType;
 441     // for enum/bitset types
 442     property ebsTypeCount: Integer read getEBSTypeCount;
 443     property ebsTypeAt[idx: Integer]: TDynEBS read getEBSTypeAt;
 444     property ebsType[const aname: AnsiString]: TDynEBS read findEBSType;
 445     // for trigtypes
 446     property trigTypeCount: Integer read getTrigTypeCount;
 447     property trigTypeAt[idx: Integer]: TDynRecord read getTrigTypeAt;
 448     property trigTypeFor[const aname: AnsiString]: TDynRecord read findTrigFor;
 449   end;
 450
 451
 452 {$IF DEFINED(D2D_DYNREC_PROFILER)}
 453 procedure xdynDumpProfiles ();
 454 {$ENDIF}
 455
 456
 457 implementation
 458
 459 uses
 460   e_log
 461   {$IF DEFINED(D2D_DYNREC_PROFILER)},xprofiler{$ENDIF};
 462
 463
 464 // ////////////////////////////////////////////////////////////////////////// //
 465 function StrEqu (const a, b: AnsiString): Boolean; inline; begin result := (a = b); end;
 466
 467
 468 // ////////////////////////////////////////////////////////////////////////// //
 469 constructor TDynRecException.Create (const amsg: AnsiString);
 470 begin
 471   inherited Create(amsg);
 472 end;
 473
 474 constructor TDynRecException.CreateFmt (const afmt: AnsiString; const args: array of const);
 475 begin
 476   inherited Create(formatstrf(afmt, args));
 477 end;
 478
 479
 480 // ////////////////////////////////////////////////////////////////////////// //
 481 constructor TDynParseException.Create (pr: TTextParser; const amsg: AnsiString);
 482 begin
 483   if (pr <> nil) then begin tokLine := pr.tokLine; tokCol := pr.tokCol; end else begin tokLine := 0; tokCol := 0; end;
 484   inherited Create(amsg);
 485 end;
 486
 487 constructor TDynParseException.CreateFmt (pr: TTextParser; const afmt: AnsiString; const args: array of const);
 488 begin
 489   if (pr <> nil) then begin tokLine := pr.tokLine; tokCol := pr.tokCol; end else begin tokLine := 0; tokCol := 0; end;
 490   inherited Create(formatstrf(afmt, args));
 491 end;
 492
 493
 494 // ////////////////////////////////////////////////////////////////////////// //
 495 function TDynField.GetEnumerator (): TDynRecList.TEnumerator; inline;
 496 begin
 497   //result := TListEnumerator.Create(mRVal);
 498   if (mRVal <> nil) then result := mRVal.GetEnumerator else result := TDynRecList.TEnumerator.Create(nil, 0);
 499 end;
 500
 501
 502 // ////////////////////////////////////////////////////////////////////////// //
 503 constructor TDynField.Create (const aname: AnsiString; atype: TType);
 504 begin
 505   mRVal := nil;
 506   mRecRef := nil;
 507   mRHash := nil;
 508   cleanup();
 509   mName := aname;
 510   mType := atype;
 511   if (mType = TType.TList) then
 512   begin
 513     mRVal := TDynRecList.Create();
 514     mRHash := hashNewStrInt();
 515   end;
 516 end;
 517
 518
 519 constructor TDynField.Create (pr: TTextParser);
 520 begin
 521   cleanup();
 522   parseDef(pr);
 523 end;
 524
 525
 526 constructor TDynField.Create (const aname: AnsiString; val: Variant);
 527   procedure setInt32 (v: LongInt);
 528   begin
 529     case mType of
 530       TType.TBool:
 531              if (v = 0) then mIVal := 0
 532         else if (v = 1) then mIVal := 1
 533         else raise TDynRecException.Create('cannot convert shortint variant to field value');
 534       TType.TByte:
 535              if (v >= -128) and (v <= 127) then mIVal := v
 536         else raise TDynRecException.Create('cannot convert shortint variant to field value');
 537       TType.TUByte:
 538              if (v >= 0) and (v <= 255) then mIVal := v
 539         else raise TDynRecException.Create('cannot convert shortint variant to field value');
 540       TType.TShort:
 541              if (v >= -32768) and (v <= 32767) then mIVal := v
 542         else raise TDynRecException.Create('cannot convert shortint variant to field value');
 543       TType.TUShort:
 544              if (v >= 0) and (v <= 65535) then mIVal := v
 545         else raise TDynRecException.Create('cannot convert shortint variant to field value');
 546       TType.TInt:
 547         mIVal := v;
 548       TType.TUInt:
 549         mIVal := v;
 550       TType.TString:
 551         mSVal := formatstrf('%s', [v]);
 552       else
 553         raise TDynRecException.Create('cannot convert integral variant to field value');
 554     end;
 555   end;
 556 begin
 557   mRVal := nil;
 558   mRecRef := nil;
 559   mRHash := nil;
 560   cleanup();
 561   mName := aname;
 562   case varType(val) of
 563     varEmpty: raise TDynRecException.Create('cannot convert empty variant to field value');
 564     varNull: raise TDynRecException.Create('cannot convert null variant to field value');
 565     varSingle: raise TDynRecException.Create('cannot convert single variant to field value');
 566     varDouble: raise TDynRecException.Create('cannot convert double variant to field value');
 567     varDecimal: raise TDynRecException.Create('cannot convert decimal variant to field value');
 568     varCurrency: raise TDynRecException.Create('cannot convert currency variant to field value');
 569     varDate: raise TDynRecException.Create('cannot convert date variant to field value');
 570     varOleStr: raise TDynRecException.Create('cannot convert olestr variant to field value');
 571     varStrArg: raise TDynRecException.Create('cannot convert stdarg variant to field value');
 572     varString: mType := TType.TString;
 573     varDispatch: raise TDynRecException.Create('cannot convert dispatch variant to field value');
 574     varBoolean: mType := TType.TBool;
 575     varVariant: raise TDynRecException.Create('cannot convert variant variant to field value');
 576     varUnknown: raise TDynRecException.Create('cannot convert unknown variant to field value');
 577     varByte: mType := TType.TUByte;
 578     varWord: mType := TType.TUShort;
 579     varShortInt: mType := TType.TByte;
 580     varSmallint: mType := TType.TShort;
 581     varInteger: mType := TType.TInt;
 582     varInt64: raise TDynRecException.Create('cannot convert int64 variant to field value');
 583     varLongWord: raise TDynRecException.Create('cannot convert longword variant to field value');
 584     varQWord: raise TDynRecException.Create('cannot convert uint64 variant to field value');
 585     varError: raise TDynRecException.Create('cannot convert error variant to field value');
 586     else raise TDynRecException.Create('cannot convert undetermined variant to field value');
 587   end;
 588   value := val;
 589 end;
 590
 591
 592 destructor TDynField.Destroy ();
 593 begin
 594   cleanup();
 595   inherited;
 596 end;
 597
 598
 599 procedure TDynField.cleanup ();
 600 begin
 601   mName := '';
 602   mType := TType.TInt;
 603   mIVal := 0;
 604   mIVal2 := 0;
 605   mSVal := '';
 606   mRVal.Free();
 607   mRVal := nil;
 608   mRHash.Free();
 609   mRHash := nil;
 610   mRecRef := nil;
 611   mMaxDim := -1;
 612   mBinOfs := -1;
 613   mSepPosSize := false;
 614   mAsT := false;
 615   mHasDefault := false;
 616   mDefined := false;
 617   mWriteDef := false;
 618   mInternal := true;
 619   mDefUnparsed := '';
 620   mDefSVal := '';
 621   mDefIVal := 0;
 622   mDefIVal2 := 0;
 623   mDefRecRef := nil;
 624   mEBS := TEBS.TNone;
 625   mEBSTypeName := '';
 626   mEBSType := nil;
 627   mBitSetUnique := false;
 628   mAsMonsterId := false;
 629   mNegBool := false;
 630   mRecRefId := '';
 631   mTagInt := 0;
 632   mTagPtr := nil;
 633   mAlias := '';
 634 end;
 635
 636
 637 function TDynField.clone (newOwner: TDynRecord=nil; registerIn: TDynRecord=nil): TDynField;
 638 var
 639   rec: TDynRecord;
 640 begin
 641   result := TDynField.Create(mName, mType);
 642   result.mOwner := mOwner;
 643   if (newOwner <> nil) then result.mOwner := newOwner else result.mOwner := mOwner;
 644   result.mName := mName;
 645   result.mType := mType;
 646   result.mIVal := mIVal;
 647   result.mIVal2 := mIVal2;
 648   result.mSVal := mSVal;
 649   if (mRVal <> nil) then
 650   begin
 651     if (result.mRVal = nil) then result.mRVal := TDynRecList.Create(mRVal.count);
 652     if (result.mRHash = nil) then result.mRHash := hashNewStrInt();
 653     for rec in mRVal do result.addListItem(rec.clone(registerIn));
 654   end;
 655   result.mRecRef := mRecRef;
 656   result.mMaxDim := mMaxDim;
 657   result.mBinOfs := mBinOfs;
 658   result.mSepPosSize := mSepPosSize;
 659   result.mAsT := mAsT;
 660   result.mDefined := mDefined;
 661   result.mHasDefault := mHasDefault;
 662   result.mWriteDef := mWriteDef;
 663   result.mInternal := mInternal;
 664   result.mNegBool := mNegBool;
 665   result.mBitSetUnique := mBitSetUnique;
 666   result.mAsMonsterId := mAsMonsterId;
 667   result.mDefUnparsed := mDefUnparsed;
 668   result.mDefSVal := mDefSVal;
 669   result.mDefIVal := mDefIVal;
 670   result.mDefIVal2 := mDefIVal2;
 671   result.mDefRecRef := mDefRecRef;
 672   result.mEBS := mEBS;
 673   result.mEBSTypeName := mEBSTypeName;
 674   result.mEBSType := mEBSType;
 675   result.mRecRefId := mRecRefId;
 676   result.mTagInt := mTagInt;
 677   result.mTagPtr := mTagPtr;
 678   result.mAlias := mAlias;
 679 end;
 680
 681
 682 function TDynField.palias (firstUp: Boolean=false): AnsiString;
 683 var
 684   nextUp: Boolean;
 685   ch: AnsiChar;
 686 begin
 687   if (Length(mAlias) > 0) then
 688   begin
 689     if firstUp then result := UpCase1251(mAlias[1])+Copy(mAlias, 2, Length(mAlias)-1) else result := mAlias;
 690   end
 691   else
 692   begin
 693     result := '';
 694     nextUp := firstUp;
 695     for ch in mName do
 696     begin
 697       if (ch = '_') then begin nextUp := true; continue; end;
 698       if nextUp then result += UpCase1251(ch) else result += ch;
 699       nextUp := false;
 700     end;
 701   end;
 702 end;
 703
 704
 705 procedure TDynField.setRecRef (arec: TDynRecord);
 706 var
 707   trc: TDynRecord = nil;
 708 begin
 709   case mEBS of
 710     TEBS.TNone: raise TDynRecException.CreateFmt('cannot set refrec for non-reference field ''%s''', [mName]);
 711     TEBS.TRec:
 712       begin
 713         if (arec <> nil) then
 714         begin
 715           if (mEBSType <> nil) and (mEBSType is TDynRecord) then trc := (mEBSType as TDynRecord);
 716           if (trc = nil) then raise TDynRecException.CreateFmt('cannot set refrec for field ''%s'' (type conflict: improperly initialized field)', [mName]);
 717           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]);
 718         end;
 719         mRecRef := arec;
 720         mDefined := true;
 721         exit;
 722       end;
 723     TEBS.TEnum: raise TDynRecException.CreateFmt('cannot set refrec for enum field ''%s''', [mName]);
 724     TEBS.TBitSet: raise TDynRecException.CreateFmt('cannot set refrec for bitset field ''%s''', [mName]);
 725     else raise TDynRecException.Create('ketmar forgot to process some reftypes');
 726   end;
 727 end;
 728
 729
 730 function TDynField.getVar (): Variant;
 731 begin
 732   if (mEBS = TEBS.TRec) then begin result := LongInt(getRecRefIndex); exit; end;
 733   case mType of
 734     TType.TBool: result := (mIVal <> 0);
 735     TType.TChar: result := mSVal;
 736     TType.TByte: result := ShortInt(mIVal);
 737     TType.TUByte: result := Byte(mIVal);
 738     TType.TShort: result := SmallInt(mIVal);
 739     TType.TUShort: result := Word(mIVal);
 740     TType.TInt: result := LongInt(mIVal);
 741     TType.TUInt: result := LongWord(mIVal);
 742     TType.TString: result := mSVal;
 743     TType.TPoint: raise TDynRecException.Create('cannot convert point field to variant');
 744     TType.TSize: raise TDynRecException.Create('cannot convert size field to variant');
 745     TType.TList: raise TDynRecException.Create('cannot convert list field to variant');
 746     TType.TTrigData: raise TDynRecException.Create('cannot convert trigdata field to variant');
 747     else result := Unassigned; raise TDynRecException.Create('ketmar forgot to handle some field type');
 748   end;
 749 end;
 750
 751
 752 procedure TDynField.setVar (val: Variant);
 753   procedure setInt32 (v: LongInt);
 754   begin
 755     case mType of
 756       TType.TBool:
 757              if (v = 0) then mIVal := 0
 758         else if (v = 1) then mIVal := 1
 759         else raise TDynRecException.Create('cannot convert shortint variant to field value');
 760       TType.TByte:
 761              if (v >= -128) and (v <= 127) then mIVal := v
 762         else raise TDynRecException.Create('cannot convert shortint variant to field value');
 763       TType.TUByte:
 764              if (v >= 0) and (v <= 255) then mIVal := v
 765         else raise TDynRecException.Create('cannot convert shortint variant to field value');
 766       TType.TShort:
 767              if (v >= -32768) and (v <= 32767) then mIVal := v
 768         else raise TDynRecException.Create('cannot convert shortint variant to field value');
 769       TType.TUShort:
 770              if (v >= 0) and (v <= 65535) then mIVal := v
 771         else raise TDynRecException.Create('cannot convert shortint variant to field value');
 772       TType.TInt:
 773         mIVal := v;
 774       TType.TUInt:
 775         mIVal := v;
 776       TType.TString:
 777         mSVal := formatstrf('%s', [v]);
 778       else
 779         raise TDynRecException.Create('cannot convert integral variant to field value');
 780     end;
 781   end;
 782 begin
 783   case varType(val) of
 784     varEmpty: raise TDynRecException.Create('cannot convert empty variant to field value');
 785     varNull: raise TDynRecException.Create('cannot convert null variant to field value');
 786     varSingle: raise TDynRecException.Create('cannot convert single variant to field value');
 787     varDouble: raise TDynRecException.Create('cannot convert double variant to field value');
 788     varDecimal: raise TDynRecException.Create('cannot convert decimal variant to field value');
 789     varCurrency: raise TDynRecException.Create('cannot convert currency variant to field value');
 790     varDate: raise TDynRecException.Create('cannot convert date variant to field value');
 791     varOleStr: raise TDynRecException.Create('cannot convert olestr variant to field value');
 792     varStrArg: raise TDynRecException.Create('cannot convert stdarg variant to field value');
 793     varString:
 794       if (mType = TType.TChar) or (mType = TType.TString) then
 795       begin
 796         mSVal := val;
 797       end
 798       else
 799       begin
 800         raise TDynRecException.Create('cannot convert string variant to field value');
 801       end;
 802     varDispatch: raise TDynRecException.Create('cannot convert dispatch variant to field value');
 803     varBoolean:
 804       case mType of
 805         TType.TBool,
 806         TType.TByte,
 807         TType.TUByte,
 808         TType.TShort,
 809         TType.TUShort,
 810         TType.TInt,
 811         TType.TUInt:
 812           if val then mIVal := 1 else mIVal := 0;
 813         TType.TString:
 814           if val then mSVal := 'true' else mSVal := 'false';
 815         else
 816           raise TDynRecException.Create('cannot convert boolean variant to field value');
 817       end;
 818     varVariant: raise TDynRecException.Create('cannot convert variant variant to field value');
 819     varUnknown: raise TDynRecException.Create('cannot convert unknown variant to field value');
 820     varByte,
 821     varWord,
 822     varShortInt,
 823     varSmallint,
 824     varInteger:
 825       setInt32(val);
 826     varInt64:
 827       if (val < Int64(LongInt($80000000))) or (val > LongInt($7FFFFFFF)) then
 828         raise TDynRecException.Create('cannot convert boolean variant to field value')
 829       else
 830         mIVal := LongInt(val);
 831     varLongWord:
 832       if (val > LongWord($7FFFFFFF)) then raise TDynRecException.Create('cannot convert longword variant to field value')
 833       else setInt32(Integer(val));
 834     varQWord: raise TDynRecException.Create('cannot convert uint64 variant to field value');
 835     varError: raise TDynRecException.Create('cannot convert error variant to field value');
 836     else raise TDynRecException.Create('cannot convert undetermined variant to field value');
 837   end;
 838   mDefined := true;
 839 end;
 840
 841
 842 // won't work for lists
 843 function TDynField.isSimpleEqu (fld: TDynField): Boolean;
 844 begin
 845   if (fld = nil) or (mType <> fld.mType) then begin result := false; exit; end;
 846   case mType of
 847     TType.TBool: result := ((mIVal <> 0) = (fld.mIVal <> 0));
 848     TType.TChar: result := (mSVal = fld.mSVal);
 849     TType.TByte,
 850     TType.TUByte,
 851     TType.TShort,
 852     TType.TUShort,
 853     TType.TInt,
 854     TType.TUInt:
 855       result := (mIVal = fld.mIVal);
 856     TType.TString: result := (mSVal = fld.mSVal);
 857     TType.TPoint,
 858     TType.TSize:
 859       result := ((mIVal = fld.mIVal) and (mIVal2 = fld.mIVal2));
 860     TType.TList: result := false;
 861     TType.TTrigData:
 862       begin
 863         if (mRecRef = nil) then begin result := (fld.mRecRef = nil); exit; end;
 864         result := mRecRef.isSimpleEqu(fld.mRecRef);
 865       end;
 866     else raise TDynRecException.Create('ketmar forgot to handle some field type');
 867   end;
 868 end;
 869
 870
 871 procedure TDynField.setValue (const s: AnsiString);
 872 var
 873   stp: TTextParser;
 874 begin
 875   stp := TStrTextParser.Create(s+';');
 876   try
 877     parseValue(stp);
 878   finally
 879     stp.Free();
 880   end;
 881 end;
 882
 883
 884 procedure TDynField.parseDefaultValue ();
 885 var
 886   stp: TTextParser = nil;
 887   oSVal: AnsiString;
 888   oIVal, oIVal2: Integer;
 889   oRRef: TDynRecord;
 890   oDef: Boolean;
 891 begin
 892   if not mHasDefault then
 893   begin
 894     mDefSVal := '';
 895     mDefIVal := 0;
 896     mDefIVal2 := 0;
 897     mDefRecRef := nil;
 898   end
 899   else
 900   begin
 901     oSVal := mSVal;
 902     oIVal := mIVal;
 903     oIVal2 := mIVal2;
 904     oRRef := mRecRef;
 905     oDef := mDefined;
 906     try
 907       stp := TStrTextParser.Create(mDefUnparsed+';');
 908       parseValue(stp);
 909       mDefSVal := mSVal;
 910       mDefIVal := mIVal;
 911       mDefIVal2 := mIVal2;
 912       mDefRecRef := mRecRef;
 913     finally
 914       mSVal := oSVal;
 915       mIVal := oIVal;
 916       mIVal2 := oIVal2;
 917       mRecRef := oRRef;
 918       mDefined := oDef;
 919       stp.Free();
 920     end;
 921   end;
 922 end;
 923
 924
 925 // default value should be parsed
 926 procedure TDynField.fixDefaultValue ();
 927 begin
 928   if mDefined then exit;
 929   if not mHasDefault then
 930   begin
 931     if mInternal then exit;
 932     raise TDynRecException.CreateFmt('field ''%s'' in record ''%s'' of record type ''%s'' is not set', [mName, mOwner.mId, mOwner.mTypeName]);
 933   end;
 934   if (mEBS = TEBS.TRec) then mRecRef := mDefRecRef;
 935   mSVal := mDefSVal;
 936   mIVal := mDefIVal;
 937   mIVal2 := mDefIVal2;
 938   mDefined := true;
 939 end;
 940
 941
 942 // default value should be parsed
 943 function TDynField.isDefaultValue (): Boolean;
 944 begin
 945   if not mHasDefault then begin result := false; exit; end;
 946   if (mEBS = TEBS.TRec) then begin result := (mRecRef = mDefRecRef); exit; end;
 947   case mType of
 948     TType.TChar, TType.TString: result := (mSVal = mDefSVal);
 949     TType.TPoint, TType.TSize: result := (mIVal = mDefIVal2) and (mIVal2 = mDefIVal2);
 950     TType.TList, TType.TTrigData: result := false; // no default values for those types
 951     else result := (mIVal = mDefIVal);
 952   end;
 953 end;
 954
 955
 956 function TDynField.getListCount (): Integer; inline;
 957 begin
 958   if (mRVal <> nil) then result := mRVal.count else result := 0;
 959 end;
 960
 961
 962 function TDynField.getListItem (idx: Integer): TDynRecord; inline; overload;
 963 begin
 964   if (mRVal <> nil) and (idx >= 0) and (idx < mRVal.count) then result := mRVal[idx] else result := nil;
 965 end;
 966
 967
 968 function TDynField.getListItem (const aname: AnsiString): TDynRecord; inline; overload;
 969 var
 970   idx: Integer;
 971 begin
 972   if (mRVal <> nil) and mRHash.get(aname, idx) then result := mRVal[idx] else result := nil;
 973 end;
 974
 975
 976 function TDynField.addListItem (rec: TDynRecord): Boolean; inline;
 977 begin
 978   result := false;
 979   if (mRVal <> nil) then
 980   begin
 981     mRVal.append(rec);
 982     if (Length(rec.mId) > 0) then result := mRHash.put(rec.mId, mRVal.count-1);
 983   end;
 984 end;
 985
 986
 987 function TDynField.removeListItem (const aid: AnsiString): TDynRecord;
 988 var
 989   f, idx: Integer;
 990 begin
 991   result := nil;
 992   if mRHash.get(aid, idx) then
 993   begin
 994     assert((idx >= 0) and (idx < mRVal.count));
 995     result := mRVal[idx];
 996     // fix hash and list
 997     for f := idx+1 to mRVal.count-1 do
 998     begin
 999       if (Length(mRVal[f].mId) > 0) then mRHash.put(mRVal[f].mId, f-1);
1000     end;
1001     mRHash.del(aid);
1002     mRVal.delete(idx);
1003   end;
1004 end;
1005
1006
1007 class function TDynField.getTypeName (t: TType): AnsiString;
1008 begin
1009   case t of
1010     TType.TBool: result := 'bool';
1011     TType.TChar: result := 'char';
1012     TType.TByte: result := 'byte';
1013     TType.TUByte: result := 'ubyte';
1014     TType.TShort: result := 'short';
1015     TType.TUShort: result := 'ushort';
1016     TType.TInt: result := 'int';
1017     TType.TUInt: result := 'uint';
1018     TType.TString: result := 'string';
1019     TType.TPoint: result := 'point';
1020     TType.TSize: result := 'size';
1021     TType.TList: result := 'array';
1022     TType.TTrigData: result := 'trigdata';
1023     else raise TDynRecException.Create('ketmar forgot to handle some field type');
1024   end;
1025 end;
1026
1027
1028 function TDynField.definition (): AnsiString;
1029 begin
1030   result := quoteStr(mName)+' type ';
1031   result += getTypeName(mType);
1032   if (Length(mAlias) > 0) then result += ' alias '+mAlias;
1033   if (mMaxDim >= 0) then result += Format('[%d]', [mMaxDim]);
1034   if (mBinOfs >= 0) then result += Format(' offset %d', [mBinOfs]);
1035   case mEBS of
1036     TEBS.TNone: begin end;
1037     TEBS.TRec: result += ' '+mEBSTypeName;
1038     TEBS.TEnum: result += ' enum '+mEBSTypeName;
1039     TEBS.TBitSet: begin result += ' bitset '; if mBitSetUnique then result += 'unique '; result += mEBSTypeName; end;
1040   end;
1041   if mAsMonsterId then result += ' as monsterid';
1042   if mHasDefault and (Length(mDefUnparsed) > 0) then result += ' default '+mDefUnparsed;
1043   if mSepPosSize then
1044   begin
1045          if (mType = TType.TPoint) then begin if (mAsT) then result += ' as txy' else result += ' as xy'; end
1046     else if (mType = TType.TSize) then begin if (mAsT) then result += ' as twh' else result += ' as wh'; end;
1047   end;
1048   if mWriteDef then result += ' writedefault';
1049   if mInternal then result += ' internal';
1050 end;
1051
1052
1053 procedure TDynField.parseDef (pr: TTextParser);
1054 var
1055   fldname: AnsiString;
1056   fldtype: AnsiString;
1057   fldofs: Integer;
1058   fldrecname: AnsiString;
1059   asxy, aswh, ast: Boolean;
1060   ainternal: Boolean;
1061   writedef: Boolean;
1062   defstr: AnsiString;
1063   defint, defint2: Integer;
1064   hasdefStr: Boolean;
1065   hasdefInt: Boolean;
1066   hasdefId: Boolean;
1067   lmaxdim: Integer;
1068   lebs: TDynField.TEBS;
1069   unique: Boolean;
1070   asmonid: Boolean;
1071   defech: AnsiChar;
1072   xalias: AnsiString;
1073 begin
1074   fldname := '';
1075   fldtype := '';
1076   fldofs := -1;
1077   fldrecname := '';
1078   asxy := false;
1079   aswh := false;
1080   ast := false;
1081   ainternal := false;
1082   writedef := false;
1083   defstr := '';
1084   defint := 0;
1085   defint2 := 0;
1086   hasdefStr := false;
1087   hasdefInt := false;
1088   hasdefId := false;
1089   unique := false;
1090   asmonid := false;
1091   lmaxdim := -1;
1092   lebs := TDynField.TEBS.TNone;
1093   xalias := '';
1094
1095   // field name
1096   fldname := pr.expectStrOrId();
1097
1098   while (pr.tokType <> pr.TTSemi) do
1099   begin
1100     if pr.eatId('type') then
1101     begin
1102       if (Length(fldtype) > 0) then raise TDynParseException.CreateFmt(pr, 'duplicate type definition for field ''%s''', [fldname]);
1103       // field type
1104       fldtype := pr.expectId();
1105       // fixed-size array?
1106       if pr.eatDelim('[') then
1107       begin
1108         lmaxdim := pr.expectInt();
1109         // arbitrary limits
1110         if (lmaxdim < 1) or (lmaxdim > 32768) then raise TDynParseException.CreateFmt(pr, 'invalid field ''%s'' array size', [fldname]);
1111         pr.expectDelim(']');
1112       end;
1113       continue;
1114     end;
1115
1116     if pr.eatId('alias') then
1117     begin
1118       if (Length(xalias) > 0) then raise TDynParseException.CreateFmt(pr, 'duplicate alias definition for field ''%s''', [fldname]);
1119       xalias := pr.expectId();
1120       continue;
1121     end;
1122
1123     if pr.eatId('offset') then
1124     begin
1125       if (fldofs >= 0) then raise TDynParseException.CreateFmt(pr, 'duplicate field ''%s'' offset', [fldname]);
1126       fldofs := pr.expectInt();
1127       if (fldofs < 0) then raise TDynParseException.CreateFmt(pr, 'invalid field ''%s'' offset', [fldname]);
1128       continue;
1129     end;
1130
1131     if pr.eatId('as') then
1132     begin
1133            if pr.eatId('xy') then asxy := true
1134       else if pr.eatId('wh') then aswh := true
1135       else if pr.eatId('txy') then begin asxy := true; ast := true; end
1136       else if pr.eatId('twh') then begin aswh := true; ast := true; end
1137       else if pr.eatId('monsterid') then begin asmonid := true; end
1138       else raise TDynParseException.CreateFmt(pr, 'invalid field ''%s'' as what?', [fldname]);
1139       continue;
1140     end;
1141
1142     if pr.eatId('enum') then
1143     begin
1144       lebs := TDynField.TEBS.TEnum;
1145       if (Length(fldrecname) <> 0) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' already typed as ''%s''', [fldname, fldrecname]);
1146       fldrecname := pr.expectId();
1147       continue;
1148     end;
1149
1150     if pr.eatId('bitset') then
1151     begin
1152       lebs := TDynField.TEBS.TBitSet;
1153       if (Length(fldrecname) <> 0) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' already typed as ''%s''', [fldname, fldrecname]);
1154       unique := pr.eatId('unique');
1155       fldrecname := pr.expectId();
1156       continue;
1157     end;
1158
1159     if pr.eatId('default') then
1160     begin
1161       if hasdefStr or hasdefInt or hasdefId then raise TDynParseException.CreateFmt(pr, 'field ''%s'' has duplicate default', [fldname]);
1162       case pr.tokType of
1163         pr.TTStr:
1164           begin
1165             hasdefStr := true;
1166             defstr := pr.expectStr(true); // allow empty strings
1167           end;
1168         pr.TTId:
1169           begin
1170             hasdefId := true;
1171             defstr := pr.expectId();
1172           end;
1173         pr.TTInt:
1174           begin
1175             hasdefInt := true;
1176             defint := pr.expectInt();
1177           end;
1178         pr.TTDelim:
1179           begin
1180             hasdefInt := true;
1181             if pr.eatDelim('[') then defech := ']' else begin pr.expectDelim('('); defech := ')'; end;
1182             defint := pr.expectInt();
1183             defint2 := pr.expectInt();
1184             pr.expectDelim(defech);
1185           end;
1186         else
1187           raise TDynParseException.CreateFmt(pr, 'field ''%s'' has invalid default', [fldname]);
1188       end;
1189       continue;
1190     end;
1191
1192     if pr.eatId('writedefault') then
1193     begin
1194       writedef := true;
1195       continue;
1196     end;
1197
1198     if pr.eatId('internal') then
1199     begin
1200       ainternal := true;
1201       continue;
1202     end;
1203
1204     // record type, no special modifiers
1205     if (pr.tokType <> pr.TTId) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' has something unexpected in definition', [fldname]);
1206
1207     if (Length(fldrecname) <> 0) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' already typed as ''%s''', [fldname, fldrecname]);
1208     fldrecname := pr.expectId();
1209     lebs := TDynField.TEBS.TRec;
1210   end;
1211
1212   pr.expectTT(pr.TTSemi);
1213
1214   // create field
1215   mName := fldname;
1216        if (fldtype = 'bool') then mType := TType.TBool
1217   else if (fldtype = 'negbool') then begin mType := TType.TBool; mNegBool := true; end
1218   else if (fldtype = 'char') then mType := TType.TChar
1219   else if (fldtype = 'byte') then mType := TType.TByte
1220   else if (fldtype = 'ubyte') then mType := TType.TUByte
1221   else if (fldtype = 'short') then mType := TType.TShort
1222   else if (fldtype = 'ushort') then mType := TType.TUShort
1223   else if (fldtype = 'int') then mType := TType.TInt
1224   else if (fldtype = 'uint') then mType := TType.TUInt
1225   else if (fldtype = 'string') then mType := TType.TString
1226   else if (fldtype = 'point') then mType := TType.TPoint
1227   else if (fldtype = 'size') then mType := TType.TSize
1228   else if (fldtype = 'trigdata') then mType := TType.TTrigData
1229   else
1230   begin
1231     // record types defaults to int
1232     if (Length(fldrecname) > 0) then
1233     begin
1234       mType := TType.TInt;
1235     end
1236     else
1237     begin
1238       if (Length(fldtype) = 0) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' has no type', [fldname])
1239       else raise TDynParseException.CreateFmt(pr, 'field ''%s'' has invalid type ''%s''', [fldname, fldtype]);
1240     end;
1241   end;
1242
1243   // check for valid arrays
1244   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]);
1245
1246   // check for valid trigdata or record type
1247   if (mType = TType.TTrigData) then
1248   begin
1249     // trigdata
1250     if (lmaxdim < 1) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' of type ''%s'' cannot be non-array', [fldname, 'trigdata']);
1251     if (Length(fldrecname) > 0) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' of type ''%s'' cannot have another type', [fldname, 'trigdata']);
1252     lebs := TDynField.TEBS.TRec;
1253   end
1254   else if (Length(fldrecname) > 0) then
1255   begin
1256     // record
1257     if not (mType in [TType.TByte, TType.TUByte, TType.TShort, TType.TUShort, TType.TInt, TType.TUInt]) then
1258     begin
1259       raise TDynParseException.CreateFmt(pr, 'field ''%s'' of record type ''%s'' cannot have type ''%s''', [fldname, fldrecname, fldtype]);
1260     end;
1261   end;
1262
1263   // setup default value
1264        if hasdefStr then self.mDefUnparsed := quoteStr(defstr)
1265   else if hasdefId then self.mDefUnparsed := defstr
1266   else if hasdefInt then
1267   begin
1268          if (mType = TType.TPoint) then self.mDefUnparsed := Format('(%d %d)', [defint, defint2])
1269     else if (mType = TType.TSize) then self.mDefUnparsed := Format('[%d %d]', [defint, defint2])
1270     else self.mDefUnparsed := Format('%d', [defint]);
1271   end;
1272
1273   self.mHasDefault := (hasdefStr or hasdefId or hasdefInt);
1274   self.mEBS := lebs;
1275   self.mEBSTypeName := fldrecname;
1276   self.mBitSetUnique := unique;
1277   self.mAsMonsterId := asmonid;
1278   self.mMaxDim := lmaxdim;
1279   self.mBinOfs := fldofs;
1280   self.mSepPosSize := (asxy or aswh);
1281   self.mAsT := ast;
1282   self.mWriteDef := writedef;
1283   self.mInternal := ainternal;
1284   self.mAlias := xalias;
1285 end;
1286
1287
1288 function TDynField.getRecRefIndex (): Integer;
1289 begin
1290   if (mRecRef = nil) then begin result := -1; exit; end;
1291   result := mOwner.findRecordNumByType(mEBSTypeName, mRecRef);
1292 end;
1293
1294
1295 procedure TDynField.writeBinTo (st: TStream);
1296 var
1297   s: AnsiString;
1298   f: Integer;
1299   maxv: Integer;
1300   buf: PByte;
1301   ws: TStream = nil;
1302 begin
1303   case mEBS of
1304     TEBS.TNone: begin end;
1305     TEBS.TRec:
1306       begin
1307         if (mMaxDim >= 0) then
1308         begin
1309           // this must be triggerdata
1310           if (mType <> TType.TTrigData) then
1311           begin
1312             raise TDynRecException.CreateFmt('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName]);
1313           end;
1314           // write triggerdata
1315           GetMem(buf, mMaxDim);
1316           if (buf = nil) then raise TDynRecException.CreateFmt('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName]);
1317           try
1318             FillChar(buf^, mMaxDim, 0);
1319             if (mRecRef <> nil) then
1320             begin
1321               ws := TSFSMemoryChunkStream.Create(buf, mMaxDim);
1322               mRecRef.writeBinTo(ws, mMaxDim); // as trigdata
1323             end;
1324             st.WriteBuffer(buf^, mMaxDim);
1325           finally
1326             ws.Free();
1327             if (buf <> nil) then FreeMem(buf);
1328           end;
1329           exit;
1330         end;
1331         // record reference
1332         case mType of
1333           TType.TByte: maxv := 127;
1334           TType.TUByte: maxv := 254;
1335           TType.TShort: maxv := 32767;
1336           TType.TUShort: maxv := 65534;
1337           TType.TInt: maxv := $7fffffff;
1338           TType.TUInt: maxv := $7fffffff;
1339           else raise TDynRecException.CreateFmt('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName]);
1340         end;
1341         // find record number
1342         if (mRecRef <> nil) then
1343         begin
1344           f := mOwner.findRecordNumByType(mEBSTypeName, mRecRef);
1345           if (f < 0) then raise TDynRecException.CreateFmt('record reference type ''%s'' in field ''%s'' not found in record list', [mEBSTypeName, mName]);
1346           if mAsMonsterId then Inc(f);
1347           if (f > maxv) then raise TDynRecException.CreateFmt('record reference type ''%s'' in field ''%s'' has too big index', [mEBSTypeName, mName]);
1348         end
1349         else
1350         begin
1351           if mAsMonsterId then f := 0 else f := -1;
1352         end;
1353         case mType of
1354           TType.TByte, TType.TUByte: writeInt(st, Byte(f));
1355           TType.TShort, TType.TUShort: writeInt(st, SmallInt(f));
1356           TType.TInt, TType.TUInt: writeInt(st, LongWord(f));
1357           else raise TDynRecException.CreateFmt('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName]);
1358         end;
1359         exit;
1360       end;
1361     TEBS.TEnum: begin end;
1362     TEBS.TBitSet: begin end;
1363     else raise TDynRecException.Create('ketmar forgot to handle some EBS type');
1364   end;
1365
1366   case mType of
1367     TType.TBool:
1368       begin
1369         if not mNegBool then
1370         begin
1371           if (mIVal <> 0) then writeInt(st, Byte(1)) else writeInt(st, Byte(0));
1372         end
1373         else
1374         begin
1375           if (mIVal = 0) then writeInt(st, Byte(1)) else writeInt(st, Byte(0));
1376         end;
1377         exit;
1378       end;
1379     TType.TChar:
1380       begin
1381         if (mMaxDim = 0) then raise TDynRecException.CreateFmt('invalid string size definition for field ''%s''', [mName]);
1382         if (mMaxDim < 0) then
1383         begin
1384           if (Length(mSVal) <> 1) then raise TDynRecException.CreateFmt('invalid string size definition for field ''%s''', [mName]);
1385           writeInt(st, Byte(mSVal[1]));
1386         end
1387         else
1388         begin
1389           if (Length(mSVal) > mMaxDim) then raise TDynRecException.CreateFmt('invalid string size definition for field ''%s''', [mName]);
1390           s := utf2win(mSVal);
1391           if (Length(s) > 0) then st.WriteBuffer(PChar(s)^, Length(s));
1392           for f := Length(s) to mMaxDim do writeInt(st, Byte(0));
1393         end;
1394         exit;
1395       end;
1396     TType.TByte,
1397     TType.TUByte:
1398       begin
1399         // triggerdata array was processed earlier
1400         if (mMaxDim >= 0) then TDynRecException.CreateFmt('byte array in field ''%s'' cannot be written', [mName]);
1401         writeInt(st, Byte(mIVal));
1402         exit;
1403       end;
1404     TType.TShort,
1405     TType.TUShort:
1406       begin
1407         if (mMaxDim >= 0) then raise TDynRecException.CreateFmt('short array in field ''%s'' cannot be written', [mName]);
1408         writeInt(st, Word(mIVal));
1409         exit;
1410       end;
1411     TType.TInt,
1412     TType.TUInt:
1413       begin
1414         if (mMaxDim >= 0) then raise TDynRecException.CreateFmt('int array in field ''%s'' cannot be written', [mName]);
1415         writeInt(st, LongWord(mIVal));
1416         exit;
1417       end;
1418     TType.TString:
1419       begin
1420         raise TDynRecException.CreateFmt('cannot write string field ''%s''', [mName]);
1421       end;
1422     TType.TPoint:
1423       begin
1424         if (mMaxDim >= 0) then raise TDynRecException.CreateFmt('pos/size array in field ''%s'' cannot be written', [mName]);
1425         writeInt(st, LongInt(mIVal));
1426         writeInt(st, LongInt(mIVal2));
1427         exit;
1428       end;
1429     TType.TSize:
1430       begin
1431         if (mMaxDim >= 0) then raise TDynRecException.CreateFmt('pos/size array in field ''%s'' cannot be written', [mName]);
1432         writeInt(st, Word(mIVal));
1433         writeInt(st, Word(mIVal2));
1434         exit;
1435       end;
1436     TType.TList:
1437       begin
1438         assert(false);
1439         exit;
1440       end;
1441     TType.TTrigData:
1442       begin
1443         assert(false);
1444         exit;
1445       end;
1446     else raise TDynRecException.Create('ketmar forgot to handle some field type');
1447   end;
1448 end;
1449
1450
1451 procedure TDynField.writeTo (wr: TTextWriter);
1452 var
1453   es: TDynEBS = nil;
1454   f, mask: Integer;
1455   first, found: Boolean;
1456 begin
1457   wr.put(mName);
1458   wr.put(' ');
1459   case mEBS of
1460     TEBS.TNone: begin end;
1461     TEBS.TRec:
1462       begin
1463         if (mRecRef = nil) then
1464         begin
1465           if (mType = TType.TTrigData) then wr.put('{}'#10) else wr.put('null;'#10);
1466         end
1467         else if (Length(mRecRef.mId) = 0) then
1468         begin
1469           mRecRef.writeTo(wr, false); // only data, no header
1470         end
1471         else
1472         begin
1473           wr.put(mRecRef.mId);
1474           wr.put(';'#10);
1475         end;
1476         exit;
1477       end;
1478     TEBS.TEnum:
1479       begin
1480         //def := mOwner.mOwner;
1481         //es := def.ebsType[mEBSTypeName];
1482         es := nil;
1483         if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS);
1484         if (es = nil) or (not es.mIsEnum) then raise TDynRecException.CreateFmt('record enum type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]);
1485         for f := 0 to High(es.mVals) do
1486         begin
1487           if (es.mVals[f] = mIVal) then
1488           begin
1489             wr.put(es.mIds[f]);
1490             wr.put(';'#10);
1491             exit;
1492           end;
1493         end;
1494         raise TDynRecException.CreateFmt('value %d in record enum type ''%s'' for field ''%s'' not found', [mIVal, mEBSTypeName, mName]);
1495       end;
1496     TEBS.TBitSet:
1497       begin
1498         //def := mOwner.mOwner;
1499         //es := def.ebsType[mEBSTypeName];
1500         es := nil;
1501         if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS);
1502         if (es = nil) or es.mIsEnum then raise TDynRecException.CreateFmt('record bitset type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]);
1503         // none?
1504         if (mIVal = 0) then
1505         begin
1506           for f := 0 to High(es.mVals) do
1507           begin
1508             if (es.mVals[f] = 0) then
1509             begin
1510               wr.put(es.mIds[f]);
1511               wr.put(';'#10);
1512               exit;
1513             end;
1514           end;
1515           raise TDynRecException.CreateFmt('value %d in record bitset type ''%s'' for field ''%s'' not found', [0, mEBSTypeName, mName]);
1516         end;
1517         // not none
1518         mask := 1;
1519         first := true;
1520         while (mask <> 0) do
1521         begin
1522           if ((mIVal and mask) <> 0) then
1523           begin
1524             found := false;
1525             for f := 0 to High(es.mVals) do
1526             begin
1527               if (es.mVals[f] = mask) then
1528               begin
1529                 if not first then wr.put('+') else first := false;
1530                 wr.put(es.mIds[f]);
1531                 found := true;
1532                 break;
1533               end;
1534             end;
1535             if not found then raise TDynRecException.CreateFmt('value %d in record bitset type ''%s'' for field ''%s'' not found', [mask, mEBSTypeName, mName]);
1536           end;
1537           mask := mask shl 1;
1538         end;
1539         wr.put(';'#10);
1540         exit;
1541       end;
1542     else raise TDynRecException.Create('ketmar forgot to handle some EBS type');
1543   end;
1544
1545   case mType of
1546     TType.TBool:
1547       begin
1548         if (mIVal = 0) then wr.put('false;'#10) else wr.put('true;'#10);
1549         exit;
1550       end;
1551     TType.TChar:
1552       begin
1553         if (mMaxDim = 0) then raise TDynRecException.CreateFmt('invalid string size definition for field ''%s''', [mName]);
1554         wr.put(quoteStr(mSVal));
1555         wr.put(';'#10);
1556         exit;
1557       end;
1558     TType.TByte,
1559     TType.TUByte,
1560     TType.TShort,
1561     TType.TUShort,
1562     TType.TInt,
1563     TType.TUInt:
1564       begin
1565         wr.put('%d;'#10, [mIVal]);
1566         exit;
1567       end;
1568     TType.TString:
1569       begin
1570         wr.put(quoteStr(mSVal));
1571         wr.put(';'#10);
1572         exit;
1573       end;
1574     TType.TPoint,
1575     TType.TSize:
1576       begin
1577         wr.put('(%d %d);'#10, [mIVal, mIVal2]);
1578         exit;
1579       end;
1580     TType.TList:
1581       begin
1582         assert(false);
1583         exit;
1584       end;
1585     TType.TTrigData:
1586       begin
1587         assert(false);
1588         exit;
1589       end;
1590     else raise TDynRecException.Create('ketmar forgot to handle some field type');
1591   end;
1592   raise TDynRecException.CreateFmt('cannot parse field ''%s'' yet', [mName]);
1593 end;
1594
1595
1596 procedure TDynField.parseBinValue (st: TStream);
1597 var
1598   rec, rc: TDynRecord;
1599   tfld: TDynField;
1600   es: TDynEBS = nil;
1601   tdata: PByte = nil;
1602   f, mask: Integer;
1603   s: AnsiString;
1604 begin
1605   case mEBS of
1606     TEBS.TNone: begin end;
1607     TEBS.TRec:
1608       begin
1609         // this must be triggerdata
1610         if (mType = TType.TTrigData) then
1611         begin
1612           assert(mMaxDim > 0);
1613           rec := mOwner;
1614           // find trigger definition
1615           tfld := rec.trigTypeField();
1616           if (tfld = nil) then raise TDynRecException.CreateFmt('triggerdata value for field ''%s'' in record ''%s'' without TriggerType field', [mName, rec.mTypeName]);
1617           rc := mOwner.mOwner.trigTypeFor[tfld.mSVal]; // find in mapdef
1618           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]);
1619           rc := rc.clone(mOwner.mHeaderRec);
1620           rc.mHeaderRec := mOwner.mHeaderRec;
1621           // on error, it will be freed by memowner
1622           rc.parseBinValue(st, true);
1623           mRecRef := rc;
1624           mDefined := true;
1625           exit;
1626         end
1627         else
1628         begin
1629           // not a trigger data
1630           case mType of
1631             TType.TByte: f := readShortInt(st);
1632             TType.TUByte: f := readByte(st);
1633             TType.TShort: f := readSmallInt(st);
1634             TType.TUShort: f := readWord(st);
1635             TType.TInt: f := readLongInt(st);
1636             TType.TUInt: f := readLongWord(st);
1637             else raise TDynRecException.CreateFmt('invalid non-numeric type ''%s'' for field ''%s'' of record ''%s''', [getTypeName(mType), mName, mEBSTypeName]);
1638           end;
1639           if mAsMonsterId then Dec(f);
1640           if (f < 0) then mRecRefId := '' else mRecRefId := Format('%s%d', [mEBSTypeName, f]);
1641         end;
1642         mDefined := true;
1643         exit;
1644       end;
1645     TEBS.TEnum,
1646     TEBS.TBitSet:
1647       begin
1648         assert(mMaxDim < 0);
1649         case mType of
1650           TType.TByte: f := readShortInt(st);
1651           TType.TUByte: f := readByte(st);
1652           TType.TShort: f := readSmallInt(st);
1653           TType.TUShort: f := readWord(st);
1654           TType.TInt: f := readLongInt(st);
1655           TType.TUInt: f := readLongWord(st);
1656           else raise TDynRecException.CreateFmt('invalid non-numeric type ''%s'' for field ''%s'' of record ''%s''', [getTypeName(mType), mName, mEBSTypeName]);
1657         end;
1658         es := nil;
1659         if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS);
1660         if (es = nil) or (es.mIsEnum <> (mEBS = TEBS.TEnum)) then raise TDynRecException.CreateFmt('record enum type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]);
1661         mIVal := f;
1662         // build enum/bitfield values
1663         if (mEBS = TEBS.TEnum) then
1664         begin
1665           mSVal := es.nameByValue(mIVal);
1666           if (Length(mSVal) = 0) then raise TDynRecException.CreateFmt('record enum type ''%s'' for field ''%s'' has invalid value %d', [mEBSTypeName, mName, mIVal]);
1667         end
1668         else
1669         begin
1670           // special for 'none'
1671           if (mIVal = 0) then
1672           begin
1673             mSVal := es.nameByValue(mIVal);
1674             if (Length(mSVal) = 0) then raise TDynRecException.CreateFmt('record bitset type ''%s'' for field ''%s'' has invalid value %d', [mEBSTypeName, mName, mIVal]);
1675           end
1676           else
1677           begin
1678             mSVal := '';
1679             mask := 1;
1680             while (mask <> 0) do
1681             begin
1682               if ((mIVal and mask) <> 0) then
1683               begin
1684                 s := es.nameByValue(mask);
1685                 if (Length(s) = 0) then raise TDynRecException.CreateFmt('record bitset type ''%s'' for field ''%s'' has invalid value %d', [mEBSTypeName, mName, mask]);
1686                 if (Length(mSVal) <> 0) then mSVal += '+';
1687                 mSVal += s;
1688               end;
1689               mask := mask shl 1;
1690             end;
1691           end;
1692         end;
1693         //writeln('ebs <', es.mName, '>: ', mSVal);
1694         mDefined := true;
1695         exit;
1696       end;
1697     else raise TDynRecException.Create('ketmar forgot to handle some EBS type');
1698   end;
1699
1700   case mType of
1701     TType.TBool:
1702       begin
1703         f := readByte(st);
1704         if (f <> 0) then f := 1;
1705         if mNegBool then f := 1-f;
1706         mIVal := f;
1707         mDefined := true;
1708         exit;
1709       end;
1710     TType.TChar:
1711       begin
1712         if (mMaxDim < 0) then
1713         begin
1714           mIVal := readByte(st);
1715         end
1716         else
1717         begin
1718           mSVal := '';
1719           GetMem(tdata, mMaxDim);
1720           try
1721             st.ReadBuffer(tdata^, mMaxDim);
1722             f := 0;
1723             while (f < mMaxDim) and (tdata[f] <> 0) do Inc(f);
1724             if (f > 0) then
1725             begin
1726               SetLength(mSVal, f);
1727               Move(tdata^, PChar(mSVal)^, f);
1728               mSVal := win2utf(mSVal);
1729             end;
1730           finally
1731             FreeMem(tdata);
1732           end;
1733         end;
1734         mDefined := true;
1735         exit;
1736       end;
1737     TType.TByte: begin mIVal := readShortInt(st); mDefined := true; exit; end;
1738     TType.TUByte: begin mIVal := readByte(st); mDefined := true; exit; end;
1739     TType.TShort: begin mIVal := readSmallInt(st); mDefined := true; exit; end;
1740     TType.TUShort: begin mIVal := readWord(st); mDefined := true; exit; end;
1741     TType.TInt: begin mIVal := readLongInt(st); mDefined := true; exit; end;
1742     TType.TUInt: begin mIVal := readLongWord(st); mDefined := true; exit; end;
1743     TType.TString:
1744       begin
1745         raise TDynRecException.Create('cannot read strings from binaries yet');
1746         exit;
1747       end;
1748     TType.TPoint:
1749       begin
1750         mIVal := readLongInt(st);
1751         mIVal2 := readLongInt(st);
1752         mDefined := true;
1753         exit;
1754       end;
1755     TType.TSize:
1756       begin
1757         mIVal := readWord(st);
1758         mIVal2 := readWord(st);
1759         mDefined := true;
1760         exit;
1761       end;
1762     TType.TList:
1763       begin
1764         assert(false);
1765         exit;
1766       end;
1767     TType.TTrigData:
1768       begin
1769         assert(false);
1770         exit;
1771       end;
1772     else raise TDynRecException.Create('ketmar forgot to handle some field type');
1773   end;
1774   raise TDynRecException.CreateFmt('cannot parse field ''%s'' yet', [mName]);
1775 end;
1776
1777
1778 procedure TDynField.parseValue (pr: TTextParser);
1779
1780   procedure parseInt (min, max: Integer);
1781   begin
1782     mIVal := pr.expectInt();
1783     if (mIVal < min) or (mIVal > max) then raise TDynParseException.CreateFmt(pr, 'invalid %s value for field ''%s''', [getTypeName(mType), mName]);
1784     mDefined := true;
1785   end;
1786
1787 var
1788   rec, rc: TDynRecord;
1789   es: TDynEBS = nil;
1790   tfld: TDynField;
1791   tk: AnsiString;
1792   edim: AnsiChar;
1793 begin
1794   if (pr.tokType = pr.TTEOF) then raise TDynParseException.Create(pr, 'field value expected');
1795   if (pr.tokType = pr.TTSemi) then raise TDynParseException.Create(pr, 'extra semicolon');
1796   // if this field should contain struct, convert type and parse struct
1797   case mEBS of
1798     TEBS.TNone: begin end;
1799     TEBS.TRec:
1800       begin
1801         // ugly hack. sorry.
1802         if (mType = TType.TTrigData) then
1803         begin
1804           pr.expectTT(pr.TTBegin);
1805           if (pr.tokType = pr.TTEnd) then
1806           begin
1807             // '{}'
1808             mRecRef := nil;
1809             pr.expectTT(pr.TTEnd);
1810           end
1811           else
1812           begin
1813             rec := mOwner;
1814             // find trigger definition
1815             tfld := rec.trigTypeField();
1816             if (tfld = nil) then raise TDynParseException.CreateFmt(pr, 'triggerdata value for field ''%s'' in record ''%s'' without ''type'' field', [mName, rec.mTypeName]);
1817             rc := mOwner.mOwner.trigTypeFor[tfld.mSVal]; // find in mapdef
1818             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]);
1819             rc := rc.clone(mOwner.mHeaderRec);
1820             rc.mHeaderRec := mOwner.mHeaderRec;
1821             //writeln(rc.definition);
1822             // on error, it will be freed by memowner
1823             rc.parseValue(pr, true);
1824             mRecRef := rc;
1825           end;
1826           mDefined := true;
1827           pr.eatTT(pr.TTSemi); // hack: allow (but don't require) semicolon after inline records
1828           exit;
1829         end;
1830         // other record types
1831         if (pr.tokType = pr.TTId) then
1832         begin
1833           if pr.eatId('null') then
1834           begin
1835             mRecRef := nil;
1836           end
1837           else
1838           begin
1839             rec := mOwner.findRecordByTypeId(mEBSTypeName, pr.tokStr);
1840             if (rec = nil) then
1841             begin
1842               mRecRefId := pr.tokStr;
1843             end
1844             else
1845             begin
1846               mRecRef := rec;
1847               mRecRefId := '';
1848             end;
1849             pr.expectId();
1850           end;
1851           mDefined := true;
1852           pr.expectTT(pr.TTSemi);
1853           exit;
1854         end
1855         else if (pr.tokType = pr.TTBegin) then
1856         begin
1857           //rec := mOwner.mOwner.recType[mEBSTypeName]; // find in mapdef
1858           rec := nil;
1859           if (mEBSType <> nil) and (mEBSType is TDynRecord) then rec := (mEBSType as TDynRecord);
1860           if (rec = nil) then raise TDynParseException.CreateFmt(pr, 'record type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]);
1861           rc := rec.clone(mOwner.mHeaderRec);
1862           rc.mHeaderRec := mOwner.mHeaderRec;
1863           rc.parseValue(pr);
1864           mRecRef := rc;
1865           mDefined := true;
1866           if mOwner.addRecordByType(mEBSTypeName, rc) then
1867           begin
1868             raise TDynParseException.CreateFmt(pr, 'duplicate record with id ''%s'' for field ''%s'' in record ''%s''', [rc.mId, mName, mOwner.mTypeName]);
1869           end;
1870           pr.eatTT(pr.TTSemi); // hack: allow (but don't require) semicolon after inline records
1871           exit;
1872         end;
1873         pr.expectTT(pr.TTBegin);
1874       end;
1875     TEBS.TEnum:
1876       begin
1877         //es := mOwner.mOwner.ebsType[mEBSTypeName]; // find in mapdef
1878         es := nil;
1879         if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS);
1880         if (es = nil) or (not es.mIsEnum) then raise TDynParseException.CreateFmt(pr, 'record enum type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]);
1881         tk := pr.expectId();
1882         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]);
1883         mIVal := es.field[tk];
1884         mSVal := tk;
1885         //writeln('ENUM ', mEBSName, '; element <', mSVal, '> with value ', mIVal);
1886         mDefined := true;
1887         pr.expectTT(pr.TTSemi);
1888         exit;
1889       end;
1890     TEBS.TBitSet:
1891       begin
1892         //es := mOwner.mOwner.ebsType[mEBSTypeName]; // find in mapdef
1893         es := nil;
1894         if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS);
1895         if (es = nil) or es.mIsEnum then raise TDynParseException.CreateFmt(pr, 'record bitset type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]);
1896         mIVal := 0;
1897         while true do
1898         begin
1899           tk := pr.expectId();
1900           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]);
1901           mIVal := mIVal or es.field[tk];
1902           mSVal := tk;
1903           if (pr.tokType <> pr.TTDelim) or ((pr.tokChar <> '|') and (pr.tokChar <> '+')) then break;
1904           if mBitSetUnique then raise TDynParseException.CreateFmt(pr, 'record bitset of type ''%s'' for field ''%s'' expects only one value', [tk, mEBSTypeName, mName]);
1905           pr.skipToken(); // plus or pipe
1906         end;
1907         mDefined := true;
1908         pr.expectTT(pr.TTSemi);
1909         exit;
1910       end;
1911     else raise TDynParseException.Create(pr, 'ketmar forgot to handle some EBS type');
1912   end;
1913
1914   case mType of
1915     TType.TBool:
1916       begin
1917              if pr.eatId('true') or pr.eatId('tan') or pr.eatId('yes') then mIVal := 1
1918         else if pr.eatId('false') or pr.eatId('ona') or pr.eatId('no') then mIVal := 0
1919         else raise TDynParseException.CreateFmt(pr, 'invalid bool value for field ''%s''', [mName]);
1920         mDefined := true;
1921         pr.expectTT(pr.TTSemi);
1922         exit;
1923       end;
1924     TType.TChar:
1925       begin
1926         if (mMaxDim = 0) then raise TDynParseException.CreateFmt(pr, 'invalid string size definition for field ''%s''', [mName]);
1927         mSVal := pr.expectStr(true);
1928         if (mMaxDim < 0) then
1929         begin
1930           // single char
1931           if (Length(mSVal) <> 1) then raise TDynParseException.CreateFmt(pr, 'invalid string size for field ''%s''', [mName]);
1932           mIVal := Integer(mSVal[1]);
1933           mSVal := '';
1934         end
1935         else
1936         begin
1937           // string
1938           if (Length(mSVal) > mMaxDim) then raise TDynParseException.CreateFmt(pr, 'invalid string size for field ''%s''', [mName]);
1939         end;
1940         mDefined := true;
1941         pr.expectTT(pr.TTSemi);
1942         exit;
1943       end;
1944     TType.TByte:
1945       begin
1946         parseInt(-128, 127);
1947         pr.expectTT(pr.TTSemi);
1948         exit;
1949       end;
1950     TType.TUByte:
1951       begin
1952         parseInt(0, 255);
1953         pr.expectTT(pr.TTSemi);
1954         exit;
1955       end;
1956     TType.TShort:
1957       begin
1958         parseInt(-32768, 32768);
1959         pr.expectTT(pr.TTSemi);
1960         exit;
1961       end;
1962     TType.TUShort:
1963       begin
1964         parseInt(0, 65535);
1965         pr.expectTT(pr.TTSemi);
1966         exit;
1967       end;
1968     TType.TInt:
1969       begin
1970         parseInt(Integer($80000000), $7fffffff);
1971         pr.expectTT(pr.TTSemi);
1972         exit;
1973       end;
1974     TType.TUInt:
1975       begin
1976         parseInt(0, $7fffffff); //FIXME
1977         pr.expectTT(pr.TTSemi);
1978         exit;
1979       end;
1980     TType.TString:
1981       begin
1982         mSVal := pr.expectStr(true);
1983         mDefined := true;
1984         pr.expectTT(pr.TTSemi);
1985         exit;
1986       end;
1987     TType.TPoint,
1988     TType.TSize:
1989       begin
1990         if pr.eatDelim('[') then edim := ']' else begin pr.expectDelim('('); edim := ')'; end;
1991         mIVal := pr.expectInt();
1992         if (mType = TType.TSize) then
1993         begin
1994           if (mIVal < 0) or (mIVal > 32767) then raise TDynParseException.CreateFmt(pr, 'invalid %s value for field ''%s''', [getTypeName(mType), mName]);
1995         end;
1996         mIVal2 := pr.expectInt();
1997         if (mType = TType.TSize) then
1998         begin
1999           if (mIVal2 < 0) or (mIVal2 > 32767) then raise TDynParseException.CreateFmt(pr, 'invalid %s value for field ''%s''', [getTypeName(mType), mName]);
2000         end;
2001         mDefined := true;
2002         pr.expectDelim(edim);
2003         pr.expectTT(pr.TTSemi);
2004         exit;
2005       end;
2006     TType.TList:
2007       begin
2008         assert(false);
2009         exit;
2010       end;
2011     TType.TTrigData:
2012       begin
2013         assert(false);
2014         exit;
2015       end;
2016     else raise TDynParseException.Create(pr, 'ketmar forgot to handle some field type');
2017   end;
2018   raise TDynParseException.CreateFmt(pr, 'cannot parse field ''%s'' yet', [mName]);
2019 end;
2020
2021
2022 // ////////////////////////////////////////////////////////////////////////// //
2023 constructor TDynRecord.Create (pr: TTextParser);
2024 begin
2025   if (pr = nil) then raise TDynParseException.Create(pr, 'cannot create record type without type definition');
2026   mId := '';
2027   mTypeName := '';
2028   mSize := 0;
2029   mFields := TDynFieldList.Create();
2030   {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
2031   mFieldsHash := hashNewStrInt();
2032   {$ENDIF}
2033   mTrigTypes := nil;
2034   mHeader := false;
2035   mHeaderRec := nil;
2036   mBinBlock := -1;
2037   mTagInt := 0;
2038   mTagPtr := nil;
2039   parseDef(pr);
2040 end;
2041
2042
2043 constructor TDynRecord.Create ();
2044 begin
2045   mTypeName := '';
2046   mSize := 0;
2047   mFields := TDynFieldList.Create();
2048   {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
2049   mFieldsHash := hashNewStrInt();
2050   {$ENDIF}
2051   mTrigTypes := nil;
2052   mHeader := false;
2053   mHeaderRec := nil;
2054   mTagInt := 0;
2055   mTagPtr := nil;
2056   mRec2Free := nil;
2057 end;
2058
2059
2060 destructor TDynRecord.Destroy ();
2061 var
2062   fld: TDynField;
2063   rec: TDynRecord;
2064 begin
2065   if (mRec2Free <> nil) then
2066   begin
2067     for rec in mRec2Free do
2068     begin
2069       if (rec <> self) then
2070       begin
2071         //writeln(formatstrf('freeing: 0x%08x; name=%s; id=%s', [Pointer(rec), rec.mName, rec.mId]));
2072         rec.Free();
2073       end;
2074     end;
2075     mRec2Free.Free();
2076     mRec2Free := nil;
2077   end;
2078   mTypeName := '';
2079   for fld in mFields do fld.Free();
2080   mFields.Free();
2081   mFields := nil;
2082   {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
2083   mFieldsHash.Free();
2084   mFieldsHash := nil;
2085   {$ENDIF}
2086   mTrigTypes := nil;
2087   mHeaderRec := nil;
2088   mTagInt := 0;
2089   mTagPtr := nil;
2090   inherited;
2091 end;
2092
2093
2094 procedure TDynRecord.regrec (rec: TDynRecord);
2095 begin
2096   if (rec <> nil) and (rec <> self) then
2097   begin
2098     if (mRec2Free = nil) then mRec2Free := TDynRecList.Create();
2099     mRec2Free.append(rec);
2100   end;
2101 end;
2102
2103
2104 procedure TDynRecord.addField (fld: TDynField); inline;
2105 begin
2106   if (fld = nil) then raise TDynRecException.Create('cannot append nil field to record');
2107   mFields.append(fld);
2108   {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
2109   if (Length(fld.mName) > 0) then mFieldsHash.put(fld.mName, mFields.count-1);
2110   {$ENDIF}
2111 end;
2112
2113
2114 function TDynRecord.addFieldChecked (fld: TDynField): Boolean; inline; // `true`: duplicate name
2115 begin
2116   result := false;
2117   if (fld = nil) then raise TDynRecException.Create('cannot append nil field to record');
2118   {$IF not DEFINED(XDYNREC_USE_FIELDHASH)}
2119   if (Length(fld.mName) > 0) then result := hasByName(fld.mName);
2120   {$ENDIF}
2121   mFields.append(fld);
2122   {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
2123   if (Length(fld.mName) > 0) then result := mFieldsHash.put(fld.mName, mFields.count-1);
2124   {$ENDIF}
2125 end;
2126
2127
2128 function TDynRecord.findByName (const aname: AnsiString): Integer; inline;
2129 begin
2130   {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
2131   if not mFieldsHash.get(aname, result) then result := -1;
2132   {$ELSE}
2133   result := 0;
2134   while (result < mFields.count) do
2135   begin
2136     if StrEqu(aname, mFields[result].mName) then exit;
2137     Inc(result);
2138   end;
2139   result := -1;
2140   {$ENDIF}
2141 end;
2142
2143
2144 function TDynRecord.hasByName (const aname: AnsiString): Boolean; inline;
2145 begin
2146   result := (findByName(aname) >= 0);
2147 end;
2148
2149
2150 function TDynRecord.getFieldByName (const aname: AnsiString): TDynField; inline;
2151 var
2152   f: Integer;
2153 begin
2154   f := findByName(aname);
2155   if (f >= 0) then result := mFields[f] else result := nil;
2156 end;
2157
2158
2159 function TDynRecord.getFieldAt (idx: Integer): TDynField; inline;
2160 begin
2161   if (idx >= 0) and (idx < mFields.count) then result := mFields[idx] else result := nil;
2162 end;
2163
2164
2165 function TDynRecord.getCount (): Integer; inline;
2166 begin
2167   result := mFields.count;
2168 end;
2169
2170
2171 function TDynRecord.getIsTrigData (): Boolean; inline;
2172 begin
2173   result := (Length(mTrigTypes) > 0);
2174 end;
2175
2176
2177 function TDynRecord.getIsForTrig (const aname: AnsiString): Boolean; inline;
2178 var
2179   f: Integer;
2180 begin
2181   result := true;
2182   for f := 0 to High(mTrigTypes) do if StrEqu(mTrigTypes[f], aname) then exit;
2183   result := false;
2184 end;
2185
2186
2187 function TDynRecord.getForTrigCount (): Integer; inline;
2188 begin
2189   result := Length(mTrigTypes);
2190 end;
2191
2192
2193 function TDynRecord.getForTrigAt (idx: Integer): AnsiString; inline;
2194 begin
2195   if (idx >= 0) and (idx < Length(mTrigTypes)) then result := mTrigTypes[idx] else result := '';
2196 end;
2197
2198
2199 function TDynRecord.clone (registerIn: TDynRecord): TDynRecord;
2200 var
2201   fld: TDynField;
2202   f: Integer;
2203 begin
2204   result := TDynRecord.Create();
2205   result.mOwner := mOwner;
2206   result.mId := mId;
2207   result.mTypeName := mTypeName;
2208   result.mSize := mSize;
2209   result.mHeader := mHeader;
2210   result.mBinBlock := mBinBlock;
2211   result.mHeaderRec := mHeaderRec;
2212   result.mTagInt := mTagInt;
2213   result.mTagPtr := mTagPtr;
2214   if (mFields.count > 0) then
2215   begin
2216     result.mFields.capacity := mFields.count;
2217     for fld in mFields do result.addField(fld.clone(result, registerIn));
2218   end;
2219   SetLength(result.mTrigTypes, Length(mTrigTypes));
2220   for f := 0 to High(mTrigTypes) do result.mTrigTypes[f] := mTrigTypes[f];
2221   if (registerIn <> nil) then registerIn.regrec(result);
2222 end;
2223
2224
2225 function TDynRecord.findRecordByTypeId (const atypename, aid: AnsiString): TDynRecord;
2226 var
2227   fld: TDynField;
2228   idx: Integer;
2229 begin
2230   result := nil;
2231   if (Length(aid) = 0) then exit;
2232   // find record data
2233   fld := mHeaderRec.field[atypename];
2234   if (fld = nil) then exit;
2235   if (fld.mType <> fld.TType.TList) then raise TDynRecException.CreateFmt('cannot get record of type ''%s'' due to name conflict with ordinary field', [atypename]);
2236   // find by id
2237   if (fld.mRVal <> nil) then
2238   begin
2239     if fld.mRHash.get(aid, idx) then begin result := fld.mRVal[idx]; exit; end;
2240   end;
2241   // alas
2242 end;
2243
2244
2245 function TDynRecord.findRecordNumByType (const atypename: AnsiString; rc: TDynRecord): Integer;
2246 var
2247   fld: TDynField;
2248   idx: Integer;
2249 begin
2250   result := -1;
2251   // find record data
2252   fld := mHeaderRec.field[atypename];
2253   if (fld = nil) then exit;
2254   if (fld.mType <> fld.TType.TList) then raise TDynRecException.CreateFmt('cannot get record of type ''%s'' due to name conflict with ordinary field', [atypename]);
2255   // find by ref
2256   if (fld.mRVal <> nil) then
2257   begin
2258     for idx := 0 to fld.mRVal.count-1 do
2259     begin
2260       if (fld.mRVal[idx] = rc) then begin result := idx; exit; end;
2261     end;
2262   end;
2263   // alas
2264 end;
2265
2266
2267 function TDynRecord.addRecordByType (const atypename: AnsiString; rc: TDynRecord): Boolean;
2268 var
2269   fld: TDynField;
2270 begin
2271   // find record data
2272   fld := mHeaderRec.field[atypename];
2273   if (fld = nil) then
2274   begin
2275     // first record
2276     fld := TDynField.Create(atypename, TDynField.TType.TList);
2277     fld.mOwner := mHeaderRec;
2278     mHeaderRec.addField(fld);
2279   end;
2280   if (fld.mType <> fld.TType.TList) then raise TDynRecException.CreateFmt('cannot append record of type ''%s'' due to name conflict with ordinary field', [atypename]);
2281   // append
2282   if (fld.mRVal = nil) then
2283   begin
2284     fld.mRVal := TDynRecList.Create();
2285     fld.mRHash := hashNewStrInt();
2286   end;
2287   result := fld.addListItem(rc);
2288 end;
2289
2290
2291 function TDynRecord.isSimpleEqu (rec: TDynRecord): Boolean;
2292 var
2293   f: Integer;
2294 begin
2295   if (rec = nil) then begin result := false; exit; end; // self.mRecRef can't be `nil` here
2296   if (rec = self) then begin result := true; exit; end;
2297   if (mFields.count <> rec.mFields.count) then begin result := false; exit; end;
2298   result := false;
2299   for f := 0 to mFields.count-1 do
2300   begin
2301     if not mFields[f].isSimpleEqu(rec.mFields[f]) then exit;
2302   end;
2303   result := true;
2304 end;
2305
2306
2307 function TDynRecord.trigTypeField (): TDynField;
2308 var
2309   fld: TDynField;
2310   es: TDynEBS = nil;
2311 begin
2312   for fld in mFields do
2313   begin
2314     if (fld.mEBS <> TDynField.TEBS.TEnum) then continue;
2315     if not (fld.mEBSType is TDynEBS) then continue;
2316     es := (fld.mEBSType as TDynEBS);
2317     assert(es <> nil);
2318     if StrEqu(es.mTypeName, 'TriggerType') then begin result := fld; exit; end;
2319   end;
2320   result := nil;
2321 end;
2322
2323
2324 // number of records of the given instance
2325 function TDynRecord.instanceCount (const atypename: AnsiString): Integer;
2326 var
2327   fld: TDynField;
2328 begin
2329   result := 0;
2330   fld := field[atypename];
2331   if (fld <> nil) and (fld.mType = fld.TType.TList) then result := fld.mRVal.count;
2332 end;
2333
2334
2335 function TDynRecord.newTypedRecord (const atypename, aid: AnsiString): TDynRecord;
2336 var
2337   trc: TDynRecord;
2338   fld: TDynField;
2339 begin
2340   if not mHeader then raise TDynRecException.Create('cannot create new records with non-header');
2341   if (Length(aid) = 0) then raise TDynRecException.CreateFmt('cannot create new record of type ''%s'' without id', [atypename]);
2342   trc := mapdef.recType[atypename];
2343   if (trc = nil) then begin result := nil; exit; end;
2344   // check if aid is unique
2345   fld := field[atypename];
2346   if (fld <> nil) and (fld.getListItem(aid) <> nil) then raise TDynRecException.CreateFmt('cannot create record of type ''%s'' with duplicate id ''%s''', [atypename, aid]);
2347   result := trc.clone(self);
2348   result.mId := aid;
2349   addRecordByType(atypename, result);
2350 end;
2351
2352
2353 procedure TDynRecord.clearRefRecs (rec: TDynRecord);
2354   procedure clearRefs (fld: TDynField);
2355   var
2356     rc: TDynRecord;
2357   begin
2358     if (fld = nil) then exit;
2359     if (fld.mRecRef = rec) then fld.mRecRef := nil;
2360     if (fld.mType = fld.TType.TList) then for rc in fld.mRVal do rc.clearRefRecs(rec);
2361   end;
2362 var
2363   fld: TDynField;
2364 begin
2365   if (rec = nil) or (mFields = nil) then exit;
2366   for fld in mFields do clearRefs(fld);
2367 end;
2368
2369
2370 // remove record with the given type and id
2371 // return `true` if record was successfully found and removed
2372 // this will do all necessary recref cleanup too
2373 function TDynRecord.removeTypedRecord (const atypename, aid: AnsiString): Boolean;
2374 var
2375   trc, rec: TDynRecord;
2376   fld: TDynField;
2377   f: Integer;
2378   doFree: Boolean = false;
2379 begin
2380   result := false;
2381   if not mHeader then raise TDynRecException.Create('cannot remove records with non-header');
2382   if (Length(aid) = 0) then exit;
2383   trc := mapdef.recType[atypename];
2384   if (trc = nil) then exit;
2385   fld := field[atypename];
2386   if (fld = nil) then exit;
2387   rec := fld.removeListItem(aid);
2388   if (rec = nil) then exit;
2389   clearRefRecs(rec);
2390   for f := 0 to mRec2Free.count-1 do
2391   begin
2392     if (mRec2Free[f] = rec) then
2393     begin
2394       mRec2Free[f] := nil;
2395       doFree := true;
2396     end;
2397   end;
2398   if doFree then rec.Free();
2399 end;
2400
2401
2402 function TDynRecord.getUserVar (const aname: AnsiString): Variant;
2403 var
2404   fld: TDynField;
2405 begin
2406   fld := getFieldByName(aname);
2407   if (fld = nil) then result := Unassigned else result := fld.value;
2408 end;
2409
2410
2411 procedure TDynRecord.setUserVar (const aname: AnsiString; val: Variant);
2412 var
2413   fld: TDynField;
2414 begin
2415   fld := getFieldByName(aname);
2416   if (fld = nil) then
2417   begin
2418     if (Length(aname) = 0) then raise TDynRecException.Create('cannot create nameless user field');
2419     fld := TDynField.Create(aname, val);
2420     fld.mOwner := self;
2421     fld.mInternal := true;
2422     addField(fld);
2423   end
2424   else
2425   begin
2426     fld.value := val;
2427   end;
2428 end;
2429
2430
2431 procedure TDynRecord.parseDef (pr: TTextParser);
2432 var
2433   fld: TDynField;
2434   tdn: AnsiString;
2435 begin
2436   if pr.eatId('TriggerData') then
2437   begin
2438     pr.expectId('for');
2439     if pr.eatDelim('(') then
2440     begin
2441       while true do
2442       begin
2443         while pr.eatTT(pr.TTComma) do begin end;
2444         if pr.eatDelim(')') then break;
2445         tdn := pr.expectId();
2446         if isForTrig[tdn] then raise TDynParseException.CreateFmt(pr, 'duplicate trigdata ''%s'' trigtype ''%s''', [mTypeName, tdn]);
2447         SetLength(mTrigTypes, Length(mTrigTypes)+1);
2448         mTrigTypes[High(mTrigTypes)] := tdn;
2449       end;
2450     end
2451     else
2452     begin
2453       tdn := pr.expectId();
2454       SetLength(mTrigTypes, 1);
2455       mTrigTypes[0] := tdn;
2456     end;
2457     mTypeName := 'TriggerData';
2458   end
2459   else
2460   begin
2461     mTypeName := pr.expectStrOrId();
2462     while (pr.tokType <> pr.TTBegin) do
2463     begin
2464       if pr.eatId('header') then begin mHeader := true; continue; end;
2465       if pr.eatId('size') then
2466       begin
2467         if (mSize > 0) then raise TDynParseException.CreateFmt(pr, 'duplicate `size` in record ''%s''', [mTypeName]);
2468         mSize := pr.expectInt();
2469         if (mSize < 1) then raise TDynParseException.CreateFmt(pr, 'invalid record ''%s'' size: %d', [mTypeName, mSize]);
2470         pr.expectId('bytes');
2471         continue;
2472       end;
2473       if pr.eatId('binblock') then
2474       begin
2475         if (mBinBlock >= 0) then raise TDynParseException.CreateFmt(pr, 'duplicate `binblock` in record ''%s''', [mTypeName]);
2476         mBinBlock := pr.expectInt();
2477         if (mBinBlock < 1) then raise TDynParseException.CreateFmt(pr, 'invalid record ''%s'' binblock: %d', [mTypeName, mBinBlock]);
2478         continue;
2479       end;
2480     end;
2481   end;
2482
2483   pr.expectTT(pr.TTBegin);
2484   // load fields
2485   while (pr.tokType <> pr.TTEnd) do
2486   begin
2487     fld := TDynField.Create(pr);
2488     // append
2489     fld.mOwner := self;
2490     if addFieldChecked(fld) then
2491     begin
2492       fld.Free();
2493       raise TDynParseException.CreateFmt(pr, 'duplicate field ''%s''', [fld.name]);
2494     end;
2495     // done with field
2496   end;
2497   pr.expectTT(pr.TTEnd);
2498 end;
2499
2500
2501 function TDynRecord.definition (): AnsiString;
2502 var
2503   f: Integer;
2504 begin
2505   if isTrigData then
2506   begin
2507     // trigger data
2508     result := 'TriggerData for ';
2509     if (Length(mTrigTypes) > 1) then
2510     begin
2511       result += '(';
2512       for f := 0 to High(mTrigTypes) do
2513       begin
2514         if (f <> 0) then result += ', ';
2515         result += mTrigTypes[f];
2516       end;
2517       result += ')';
2518     end
2519     else
2520     begin
2521       result += mTrigTypes[0];
2522     end;
2523   end
2524   else
2525   begin
2526     // record
2527     result := quoteStr(mTypeName);
2528     if (mSize >= 0) then result += Format(' size %d bytes', [mSize]);
2529     if mHeader then result += ' header';
2530   end;
2531   result += ' {'#10;
2532   for f := 0 to mFields.count-1 do
2533   begin
2534     result += '  ';
2535     result += mFields[f].definition;
2536     result += ';'#10;
2537   end;
2538   result += '}';
2539 end;
2540
2541
2542 procedure TDynRecord.parseBinValue (st: TStream; forceData: Boolean=false);
2543 var
2544   sign: string[4];
2545   btype: Integer;
2546   bsize: Integer;
2547   buf: PByte = nil;
2548   loaded: array[0..255] of Boolean;
2549   rec, rect: TDynRecord;
2550   fld: TDynField;
2551   f: Integer;
2552   mst: TSFSMemoryChunkStream = nil;
2553
2554   procedure linkNames (rec: TDynRecord);
2555   var
2556     fld: TDynField;
2557     rt: TDynRecord;
2558   begin
2559     //writeln('*** rec: ', rec.mName, '.', rec.mId, ' (', rec.mFields.count, ')');
2560     for fld in rec.mFields do
2561     begin
2562       if (fld.mType = TDynField.TType.TTrigData) then
2563       begin
2564         if (fld.mRecRef <> nil) then linkNames(fld.mRecRef);
2565         continue;
2566       end;
2567       if (Length(fld.mRecRefId) = 0) then continue;
2568       assert(fld.mEBSType <> nil);
2569       rt := findRecordByTypeId(fld.mEBSTypeName, fld.mRecRefId);
2570       if (rt = nil) then
2571       begin
2572         e_LogWritefln('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], MSG_WARNING);
2573         //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]);
2574       end;
2575       //writeln(' ', rec.mName, '.', rec.mId, ':', fld.mName, ' -> ', rt.mName, '.', rt.mId, ' (', fld.mEBSTypeName, '.', fld.mRecRefId, ')');
2576       fld.mRecRefId := '';
2577       fld.mRecRef := rt;
2578       fld.mDefined := true;
2579     end;
2580     for fld in rec.mFields do
2581     begin
2582       //writeln('  ', fld.mName);
2583       fld.fixDefaultValue(); // just in case
2584     end;
2585   end;
2586
2587 begin
2588   for f := 0 to High(loaded) do loaded[f] := false;
2589   mst := TSFSMemoryChunkStream.Create(nil, 0);
2590   try
2591     if mHeader and not forceData then
2592     begin
2593       // parse map file as sequence of blocks
2594       sign[0] := #4;
2595       st.ReadBuffer(sign[1], 4);
2596       if (sign <> 'MAP'#1) then raise TDynRecException.Create('invalid binary map signature');
2597       // parse blocks
2598       while (st.position < st.size) do
2599       begin
2600         btype := readByte(st);
2601         if (btype = 0) then break; // no more blocks
2602         readLongWord(st); // reserved
2603         bsize := readLongInt(st);
2604         {$IF DEFINED(D2D_XDYN_DEBUG)}writeln('btype=', btype, '; bsize=', bsize);{$ENDIF}
2605         if (bsize < 0) or (bsize > $1fffffff) then raise TDynRecException.CreateFmt('block of type %d has invalid size %d', [btype, bsize]);
2606         if loaded[btype] then raise TDynRecException.CreateFmt('block of type %d already loaded', [btype]);
2607         loaded[btype] := true;
2608         // find record type for this block
2609         rect := nil;
2610         for rec in mOwner.recTypes do if (rec.mBinBlock = btype) then begin rect := rec; break; end;
2611         if (rect = nil) then raise TDynRecException.CreateFmt('block of type %d has no corresponding record', [btype]);
2612         //writeln('found type ''', rec.mName, ''' for block type ', btype);
2613         if (rec.mSize = 0) or ((bsize mod rec.mSize) <> 0) then raise TDynRecException.CreateFmt('block of type %d has invalid number of records', [btype]);
2614         // header?
2615         if (rect.mHeader) then
2616         begin
2617           if (bsize <> mSize) then raise TDynRecException.CreateFmt('header block of type %d has invalid number of records', [btype]);
2618           GetMem(buf, bsize);
2619           st.ReadBuffer(buf^, bsize);
2620           mst.setup(buf, mSize);
2621           parseBinValue(mst, true); // force parsing data
2622         end
2623         else
2624         begin
2625           // create list for this type
2626           fld := TDynField.Create(rec.mTypeName, TDynField.TType.TList);
2627           fld.mOwner := self;
2628           addField(fld);
2629           if (bsize > 0) then
2630           begin
2631             GetMem(buf, bsize);
2632             st.ReadBuffer(buf^, bsize);
2633             for f := 0 to (bsize div rec.mSize)-1 do
2634             begin
2635               mst.setup(buf+f*rec.mSize, rec.mSize);
2636               rec := rect.clone(self);
2637               rec.mHeaderRec := self;
2638               rec.parseBinValue(mst);
2639               rec.mId := Format('%s%d', [rec.mTypeName, f]);
2640               fld.addListItem(rec);
2641               //writeln('parsed ''', rec.mId, '''...');
2642             end;
2643           end;
2644         end;
2645         FreeMem(buf);
2646         buf := nil;
2647         //st.position := st.position+bsize;
2648       end;
2649       // link fields
2650       for fld in mFields do
2651       begin
2652         if (fld.mType <> TDynField.TType.TList) then continue;
2653         for rec in fld.mRVal do linkNames(rec);
2654       end;
2655       exit;
2656     end;
2657
2658     // read fields
2659     if StrEqu(mTypeName, 'TriggerData') then mSize := Integer(st.size-st.position);
2660     if (mSize < 1) then raise TDynRecException.CreateFmt('cannot read record of type ''%s'' with unknown size', [mTypeName]);
2661     GetMem(buf, mSize);
2662     st.ReadBuffer(buf^, mSize);
2663     for fld in mFields do
2664     begin
2665       if fld.mInternal then continue;
2666       if (fld.mBinOfs < 0) then continue;
2667       if (fld.mBinOfs >= st.size) then raise TDynRecException.CreateFmt('record of type ''%s'' has invalid field ''%s''', [fld.mName]);
2668       mst.setup(buf+fld.mBinOfs, mSize-fld.mBinOfs);
2669       //writeln('parsing ''', mName, '.', fld.mName, '''...');
2670       fld.parseBinValue(mst);
2671     end;
2672   finally
2673     mst.Free();
2674     if (buf <> nil) then FreeMem(buf);
2675   end;
2676 end;
2677
2678
2679 procedure TDynRecord.writeBinTo (st: TStream; trigbufsz: Integer=-1; onlyFields: Boolean=false);
2680 var
2681   fld: TDynField;
2682   rec, rv: TDynRecord;
2683   buf: PByte = nil;
2684   ws: TStream = nil;
2685   blk, blkmax: Integer;
2686   //f, c: Integer;
2687   bufsz: Integer = 0;
2688   blksz: Integer;
2689 begin
2690   if (trigbufsz < 0) then
2691   begin
2692     if (mBinBlock < 1) then raise TDynRecException.Create('cannot write binary record without block number');
2693     if (mSize < 1) then raise TDynRecException.Create('cannot write binary record without size');
2694     bufsz := mSize;
2695   end
2696   else
2697   begin
2698     bufsz := trigbufsz;
2699   end;
2700   try
2701     GetMem(buf, bufsz);
2702     FillChar(buf^, bufsz, 0);
2703     ws := TSFSMemoryChunkStream.Create(buf, bufsz);
2704
2705     // write normal fields
2706     for fld in mFields do
2707     begin
2708       // record list?
2709       if (fld.mType = fld.TType.TList) then continue; // later
2710       if fld.mInternal then continue;
2711       if (fld.mBinOfs < 0) then continue;
2712       if (fld.mBinOfs >= bufsz) then raise TDynRecException.Create('binary value offset is outside of the buffer');
2713       TSFSMemoryChunkStream(ws).setup(buf+fld.mBinOfs, bufsz-fld.mBinOfs);
2714       //writeln('writing field <', fld.mName, '>');
2715       fld.writeBinTo(ws);
2716     end;
2717
2718     // write block with normal fields
2719     if mHeader and not onlyFields then
2720     begin
2721       //writeln('writing header...');
2722       // signature and version
2723       writeIntBE(st, LongWord($4D415001));
2724       writeInt(st, Byte(mBinBlock)); // type
2725       writeInt(st, LongWord(0)); // reserved
2726       writeInt(st, LongWord(bufsz)); // size
2727     end;
2728     st.WriteBuffer(buf^, bufsz);
2729
2730     ws.Free(); ws := nil;
2731     FreeMem(buf); buf := nil;
2732
2733     // write other blocks, if any
2734     if mHeader and not onlyFields then
2735     begin
2736       // calculate blkmax
2737       blkmax := 0;
2738       for fld in mFields do
2739       begin
2740         // record list?
2741         if (fld.mType = fld.TType.TList) then
2742         begin
2743           if (fld.mRVal = nil) or (fld.mRVal.count = 0) then continue;
2744           rec := mOwner.recType[fld.mName];
2745           if (rec = nil) then continue;
2746           if (rec.mBinBlock <= 0) then continue;
2747           if (blkmax < rec.mBinBlock) then blkmax := rec.mBinBlock;
2748         end;
2749       end;
2750       // write blocks
2751       for blk := 1 to blkmax do
2752       begin
2753         if (blk = mBinBlock) then continue;
2754         ws := nil;
2755         for fld in mFields do
2756         begin
2757           // record list?
2758           if (fld.mType = fld.TType.TList) then
2759           begin
2760             if (fld.mRVal = nil) or (fld.mRVal.count = 0) then continue;
2761             rec := mOwner.recType[fld.mName];
2762             if (rec = nil) then continue;
2763             if (rec.mBinBlock <> blk) then continue;
2764             if (ws = nil) then ws := TMemoryStream.Create();
2765             for rv in fld.mRVal do rv.writeBinTo(ws);
2766           end;
2767         end;
2768         // flush block
2769         if (ws <> nil) then
2770         begin
2771           blksz := Integer(ws.position);
2772           ws.position := 0;
2773           writeInt(st, Byte(blk)); // type
2774           writeInt(st, LongWord(0)); // reserved
2775           writeInt(st, LongWord(blksz)); // size
2776           st.CopyFrom(ws, blksz);
2777           ws.Free();
2778           ws := nil;
2779         end;
2780       end;
2781       // write end marker
2782       writeInt(st, Byte(0));
2783       writeInt(st, LongWord(0));
2784       writeInt(st, LongWord(0));
2785     end;
2786   finally
2787     ws.Free();
2788     if (buf <> nil) then FreeMem(buf);
2789   end;
2790 end;
2791
2792
2793 procedure TDynRecord.writeTo (wr: TTextWriter; putHeader: Boolean=true);
2794 var
2795   fld: TDynField;
2796   rec: TDynRecord;
2797 begin
2798   if putHeader then
2799   begin
2800     wr.put(mTypeName);
2801     if (Length(mId) > 0) then begin wr.put(' '); wr.put(mId); end;
2802     wr.put(' ');
2803   end;
2804   wr.put('{'#10);
2805   wr.indent();
2806   try
2807     for fld in mFields do
2808     begin
2809       // record list?
2810       if (fld.mType = fld.TType.TList) then
2811       begin
2812         if not mHeader then raise TDynRecException.Create('record list in non-header record');
2813         if (fld.mRVal <> nil) then
2814         begin
2815           for rec in fld.mRVal do
2816           begin
2817             if (Length(rec.mId) = 0) then continue;
2818             wr.putIndent();
2819             rec.writeTo(wr, true);
2820           end;
2821         end;
2822         continue;
2823       end;
2824       if fld.mInternal then continue;
2825       if (not fld.mWriteDef) and fld.isDefaultValue then continue;
2826       wr.putIndent();
2827       fld.writeTo(wr);
2828     end;
2829   finally
2830     wr.unindent();
2831   end;
2832   wr.putIndent();
2833   wr.put('}'#10);
2834 end;
2835
2836
2837 {$IF DEFINED(D2D_DYNREC_PROFILER)}
2838 var
2839   profCloneRec: UInt64 = 0;
2840   profFindRecType: UInt64 = 0;
2841   profFieldSearching: UInt64 = 0;
2842   profListDupChecking: UInt64 = 0;
2843   profAddRecByType: UInt64 = 0;
2844   profFieldValParsing: UInt64 = 0;
2845   profFixDefaults: UInt64 = 0;
2846   profRecValParse: UInt64 = 0;
2847
2848 procedure xdynDumpProfiles ();
2849 begin
2850   writeln('=== XDYNREC PROFILES ===');
2851   writeln('record cloning: ', profCloneRec div 1000, '.', profCloneRec mod 1000, ' milliseconds');
2852   writeln('findRecType   : ', profFindRecType div 1000, '.', profFindRecType mod 1000, ' milliseconds');
2853   writeln('field[]       : ', profFieldSearching div 1000, '.', profFieldSearching mod 1000, ' milliseconds');
2854   writeln('list dup check: ', profListDupChecking div 1000, '.', profListDupChecking mod 1000, ' milliseconds');
2855   writeln('addRecByType  : ', profAddRecByType div 1000, '.', profAddRecByType mod 1000, ' milliseconds');
2856   writeln('field valparse: ', profFieldValParsing div 1000, '.', profFieldValParsing mod 1000, ' milliseconds');
2857   writeln('fix defaults  : ', profFixDefaults div 1000, '.', profFixDefaults mod 1000, ' milliseconds');
2858   writeln('recvalparse   : ', profRecValParse div 1000, '.', profRecValParse mod 1000, ' milliseconds');
2859 end;
2860 {$ENDIF}
2861
2862
2863 procedure TDynRecord.parseValue (pr: TTextParser; beginEaten: Boolean=false);
2864 var
2865   fld: TDynField;
2866   rec: TDynRecord = nil;
2867   trc{, rv}: TDynRecord;
2868   {$IF DEFINED(D2D_DYNREC_PROFILER)}
2869   stt, stall: UInt64;
2870   {$ENDIF}
2871
2872   procedure linkNames (rec: TDynRecord);
2873   var
2874     fld: TDynField;
2875     rt: TDynRecord;
2876   begin
2877     //writeln('*** rec: ', rec.mName, '.', rec.mId, ' (', rec.mFields.count, ')');
2878     for fld in rec.mFields do
2879     begin
2880       if (fld.mType = TDynField.TType.TTrigData) then
2881       begin
2882         if (fld.mRecRef <> nil) then linkNames(fld.mRecRef);
2883         continue;
2884       end;
2885       if (Length(fld.mRecRefId) = 0) then continue;
2886       assert(fld.mEBSType <> nil);
2887       rt := findRecordByTypeId(fld.mEBSTypeName, fld.mRecRefId);
2888       if (rt = nil) then
2889       begin
2890         //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);
2891         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]);
2892       end;
2893       //writeln(' ', rec.mName, '.', rec.mId, ':', fld.mName, ' -> ', rt.mName, '.', rt.mId, ' (', fld.mEBSTypeName, '.', fld.mRecRefId, ')');
2894       fld.mRecRefId := '';
2895       fld.mRecRef := rt;
2896       fld.mDefined := true;
2897     end;
2898     for fld in rec.mFields do
2899     begin
2900       //writeln('  ', fld.mName);
2901       fld.fixDefaultValue(); // just in case
2902     end;
2903   end;
2904
2905 begin
2906   if (mOwner = nil) then raise TDynParseException.CreateFmt(pr, 'can''t parse record ''%s'' value without owner', [mTypeName]);
2907
2908   {$IF DEFINED(D2D_DYNREC_PROFILER)}stall := curTimeMicro();{$ENDIF}
2909
2910   // not a header?
2911   if not mHeader then
2912   begin
2913     // id?
2914     if (not beginEaten) and (pr.tokType = pr.TTId) then mId := pr.expectId();
2915   end
2916   else
2917   begin
2918     assert(mHeaderRec = self);
2919   end;
2920
2921   //writeln('parsing record <', mName, '>');
2922   if not beginEaten then pr.expectTT(pr.TTBegin);
2923   while (pr.tokType <> pr.TTEnd) do
2924   begin
2925     if (pr.tokType <> pr.TTId) then raise TDynParseException.Create(pr, 'identifier expected');
2926     //writeln('<', mName, '.', pr.tokStr, '>');
2927
2928     // records
2929     if mHeader then
2930     begin
2931       // add records with this type (if any)
2932       {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2933       trc := mOwner.recType[pr.tokStr];
2934       {$IF DEFINED(D2D_DYNREC_PROFILER)}profFindRecType := curTimeMicro()-stt;{$ENDIF}
2935       if (trc <> nil) then
2936       begin
2937         {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2938         rec := trc.clone(mHeaderRec);
2939         {$IF DEFINED(D2D_DYNREC_PROFILER)}profCloneRec := curTimeMicro()-stt;{$ENDIF}
2940         rec.mHeaderRec := mHeaderRec;
2941         // on error, it will be freed by memowner
2942         pr.skipToken();
2943         rec.parseValue(pr);
2944         {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2945         addRecordByType(rec.mTypeName, rec);
2946         {$IF DEFINED(D2D_DYNREC_PROFILER)}profAddRecByType := curTimeMicro()-stt;{$ENDIF}
2947         continue;
2948       end;
2949     end;
2950
2951     // fields
2952     {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2953     //writeln('0: <', mName, '.', pr.tokStr, '>');
2954     fld := field[pr.tokStr];
2955     //writeln('1: <', mName, '.', pr.tokStr, '>');
2956     {$IF DEFINED(D2D_DYNREC_PROFILER)}profFieldSearching := curTimeMicro()-stt;{$ENDIF}
2957     if (fld <> nil) then
2958     begin
2959       //writeln('2: <', mName, '.', pr.tokStr, '>');
2960       if fld.defined then raise TDynParseException.CreateFmt(pr, 'duplicate field ''%s'' in record ''%s''', [fld.mName, mTypeName]);
2961       if fld.internal then raise TDynParseException.CreateFmt(pr, 'internal field ''%s'' in record ''%s''', [fld.mName, mTypeName]);
2962       pr.skipToken(); // skip field name
2963       //writeln('3: <', mName, '.', pr.tokStr, '>:', pr.tokType);
2964       {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2965       fld.parseValue(pr);
2966       {$IF DEFINED(D2D_DYNREC_PROFILER)}profFieldValParsing := curTimeMicro()-stt;{$ENDIF}
2967       continue;
2968     end;
2969
2970     // something is wrong
2971     raise TDynParseException.CreateFmt(pr, 'unknown field ''%s'' in record ''%s''', [pr.tokStr, mTypeName]);
2972   end;
2973   pr.expectTT(pr.TTEnd);
2974
2975   if mHeader then
2976   begin
2977     // link fields
2978     for fld in mFields do
2979     begin
2980       if (fld.mType <> TDynField.TType.TList) then continue;
2981       for rec in fld.mRVal do linkNames(rec);
2982     end;
2983   end;
2984
2985   // fix field defaults
2986   {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2987   for fld in mFields do fld.fixDefaultValue();
2988   {$IF DEFINED(D2D_DYNREC_PROFILER)}profFixDefaults := curTimeMicro()-stt;{$ENDIF}
2989   //writeln('done parsing record <', mName, '>');
2990   //{$IF DEFINED(D2D_DYNREC_PROFILER)}writeln('stall: ', curTimeMicro()-stall);{$ENDIF}
2991   {$IF DEFINED(D2D_DYNREC_PROFILER)}profRecValParse := curTimeMicro()-stall;{$ENDIF}
2992 end;
2993
2994
2995 // ////////////////////////////////////////////////////////////////////////// //
2996 constructor TDynEBS.Create (pr: TTextParser);
2997 begin
2998   cleanup();
2999   parseDef(pr);
3000 end;
3001
3002
3003 destructor TDynEBS.Destroy ();
3004 begin
3005   cleanup();
3006   inherited;
3007 end;
3008
3009
3010 procedure TDynEBS.cleanup ();
3011 begin
3012   mIsEnum := false;
3013   mTypeName := '';
3014   mIds := nil;
3015   mVals := nil;
3016   mMaxName := '';
3017   mMaxVal := 0;
3018 end;
3019
3020
3021 function TDynEBS.findByName (const aname: AnsiString): Integer;
3022 begin
3023   result := 0;
3024   while (result < Length(mIds)) do
3025   begin
3026     if StrEqu(aname, mIds[result]) then exit;
3027     Inc(result);
3028   end;
3029   result := -1;
3030 end;
3031
3032
3033 function TDynEBS.hasByName (const aname: AnsiString): Boolean; inline;
3034 begin
3035   result := (findByName(aname) >= 0);
3036 end;
3037
3038
3039 function TDynEBS.getFieldByName (const aname: AnsiString): Integer; inline;
3040 var
3041   f: Integer;
3042 begin
3043   f := findByName(aname);
3044   if (f >= 0) then result := mVals[f] else result := 0;
3045 end;
3046
3047
3048 function TDynEBS.definition (): AnsiString;
3049 var
3050   f, cv: Integer;
3051 begin
3052   if mIsEnum then result :='enum ' else result := 'bitset ';
3053   result += mTypeName;
3054   result += ' {'#10;
3055   // fields
3056   if mIsEnum then cv := 0 else cv := 1;
3057   for f := 0 to High(mIds) do
3058   begin
3059     if (mIds[f] = mMaxName) then continue;
3060     result += '  '+mIds[f];
3061     if (mVals[f] <> cv) then
3062     begin
3063       result += Format(' = %d', [mVals[f]]);
3064       if mIsEnum then cv := mVals[f];
3065       result += ','#10;
3066     end
3067     else
3068     begin
3069       result += Format(', // %d'#10, [mVals[f]]);
3070     end;
3071     if mIsEnum then Inc(cv) else if (mVals[f] = cv) then cv := cv shl 1;
3072   end;
3073   // max field
3074   if (Length(mMaxName) > 0) then result += '  '+mMaxName+' = MAX,'#10;
3075   result += '}';
3076 end;
3077
3078
3079 function TDynEBS.pasdef (): AnsiString;
3080 var
3081   f: Integer;
3082 begin
3083   result := '// '+mTypeName+#10'const'#10;
3084   // fields
3085   for f := 0 to High(mIds) do
3086   begin
3087     result += formatstrf('  %s = %d;'#10, [mIds[f], mVals[f]]);
3088   end;
3089 end;
3090
3091
3092 function TDynEBS.nameByValue (v: Integer): AnsiString;
3093 var
3094   f: Integer;
3095 begin
3096   for f := 0 to High(mVals) do
3097   begin
3098     if (mVals[f] = v) then begin result := mIds[f]; exit; end;
3099   end;
3100   result := '';
3101 end;
3102
3103
3104 procedure TDynEBS.parseDef (pr: TTextParser);
3105 var
3106   idname: AnsiString;
3107   cv, v: Integer;
3108   f: Integer;
3109   skipAdd: Boolean;
3110   hasV: Boolean;
3111 begin
3112        if pr.eatId('enum') then mIsEnum := true
3113   else if pr.eatId('bitset') then mIsEnum := false
3114   else pr.expectId('enum');
3115   mTypeName := pr.expectId();
3116   mMaxVal := Integer($80000000);
3117   if mIsEnum then cv := 0 else cv := 1;
3118   pr.expectTT(pr.TTBegin);
3119   while (pr.tokType <> pr.TTEnd) do
3120   begin
3121     idname := pr.expectId();
3122     for f := 0 to High(mIds) do
3123     begin
3124       if StrEqu(mIds[f], idname) then raise TDynParseException.CreateFmt(pr, 'duplicate field ''%s'' in enum/bitset ''%s''', [idname, mTypeName]);
3125     end;
3126     if StrEqu(mMaxName, idname) then raise TDynParseException.CreateFmt(pr, 'duplicate field ''%s'' in enum/bitset ''%s''', [idname, mTypeName]);
3127     skipAdd := false;
3128     hasV := false;
3129     v := cv;
3130     // has value?
3131     if pr.eatDelim('=') then
3132     begin
3133       if pr.eatId('MAX') then
3134       begin
3135         if (Length(mMaxName) > 0) then raise TDynParseException.CreateFmt(pr, 'duplicate max field ''%s'' in enum/bitset ''%s''', [idname, mTypeName]);
3136         mMaxName := idname;
3137         skipAdd := true;
3138       end
3139       else
3140       begin
3141         v := pr.expectInt();
3142           if mIsEnum then cv := v;
3143         hasV := true;
3144       end;
3145     end;
3146     // append it?
3147     if not skipAdd then
3148     begin
3149       // fix maxvalue
3150       if mIsEnum or (not hasV) then
3151       begin
3152         if (mMaxVal < v) then mMaxVal := v;
3153       end;
3154       SetLength(mIds, Length(mIds)+1);
3155       mIds[High(mIds)] := idname;
3156       SetLength(mVals, Length(mIds));
3157       mVals[High(mVals)] := v;
3158       // next cv
3159       if mIsEnum or (not hasV) then
3160       begin
3161         if mIsEnum then Inc(cv) else cv := cv shl 1;
3162       end;
3163     end;
3164     if (pr.tokType = pr.TTEnd) then break;
3165     pr.expectTT(pr.TTComma);
3166     while pr.eatTT(pr.TTComma) do begin end;
3167   end;
3168   pr.expectTT(pr.TTEnd);
3169   // add max field
3170   if (Length(mMaxName) > 0) then
3171   begin
3172     SetLength(mIds, Length(mIds)+1);
3173     mIds[High(mIds)] := mMaxName;
3174     SetLength(mVals, Length(mIds));
3175     mVals[High(mVals)] := mMaxVal;
3176   end;
3177 end;
3178
3179
3180 // ////////////////////////////////////////////////////////////////////////// //
3181 constructor TDynMapDef.Create (pr: TTextParser);
3182 begin
3183   recTypes := TDynRecList.Create();
3184   trigTypes := TDynRecList.Create();
3185   ebsTypes := TDynEBSList.Create();
3186   parseDef(pr);
3187 end;
3188
3189
3190 destructor TDynMapDef.Destroy ();
3191 var
3192   rec: TDynRecord;
3193   ebs: TDynEBS;
3194 begin
3195   //!!!FIXME!!! check who owns trigs and recs!
3196   for rec in recTypes do rec.Free();
3197   for rec in trigTypes do rec.Free();
3198   for ebs in ebsTypes do ebs.Free();
3199   recTypes.Free();
3200   trigTypes.Free();
3201   ebsTypes.Free();
3202   recTypes := nil;
3203   trigTypes := nil;
3204   ebsTypes := nil;
3205   inherited;
3206 end;
3207
3208
3209 function TDynMapDef.getHeaderRecType (): TDynRecord; inline;
3210 begin
3211   if (recTypes.count = 0) then raise TDynRecException.Create('no header in empty mapdef');
3212   result := recTypes[0];
3213 end;
3214
3215
3216 function TDynMapDef.findRecType (const aname: AnsiString): TDynRecord;
3217 var
3218   rec: TDynRecord;
3219 begin
3220   for rec in recTypes do
3221   begin
3222     if StrEqu(rec.typeName, aname) then begin result := rec; exit; end;
3223   end;
3224   result := nil;
3225 end;
3226
3227
3228 function TDynMapDef.findTrigFor (const aname: AnsiString): TDynRecord;
3229 var
3230   rec: TDynRecord;
3231 begin
3232   for rec in trigTypes do
3233   begin
3234     if (rec.isForTrig[aname]) then begin result := rec; exit; end;
3235   end;
3236   result := nil;
3237 end;
3238
3239
3240 function TDynMapDef.findEBSType (const aname: AnsiString): TDynEBS;
3241 var
3242   ebs: TDynEBS;
3243 begin
3244   for ebs in ebsTypes do
3245   begin
3246     if StrEqu(ebs.typeName, aname) then begin result := ebs; exit; end;
3247   end;
3248   result := nil;
3249 end;
3250
3251
3252 procedure TDynMapDef.parseDef (pr: TTextParser);
3253 var
3254   rec, hdr: TDynRecord;
3255   eb: TDynEBS;
3256   f: Integer;
3257
3258   // setup header links and type links
3259   procedure linkRecord (rec: TDynRecord);
3260   var
3261     fld: TDynField;
3262   begin
3263     rec.mHeaderRec := recTypes[0];
3264     for fld in rec.mFields do
3265     begin
3266       if (fld.mType = fld.TType.TTrigData) then continue;
3267       case fld.mEBS of
3268         TDynField.TEBS.TNone: begin end;
3269         TDynField.TEBS.TRec:
3270           begin
3271             fld.mEBSType := findRecType(fld.mEBSTypeName);
3272             if (fld.mEBSType = nil) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' of type ''%s'' has no correcponding record definition', [fld.mName, fld.mEBSTypeName]);
3273           end;
3274         TDynField.TEBS.TEnum,
3275         TDynField.TEBS.TBitSet:
3276           begin
3277             fld.mEBSType := findEBSType(fld.mEBSTypeName);
3278             if (fld.mEBSType = nil) then raise TDynParseException.CreateFmt(pr, 'field ''%s'' of type ''%s'' has no correcponding enum/bitset', [fld.mName, fld.mEBSTypeName]);
3279             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]);
3280           end;
3281       end;
3282     end;
3283   end;
3284
3285   // setup default values
3286   procedure fixRecordDefaults (rec: TDynRecord);
3287   var
3288     fld: TDynField;
3289   begin
3290     for fld in rec.mFields do if fld.mHasDefault then fld.parseDefaultValue();
3291   end;
3292
3293 begin
3294   hdr := nil;
3295   while true do
3296   begin
3297     if not pr.skipBlanks() then break;
3298
3299     if (pr.tokType = pr.TTId) then
3300     begin
3301       // enum or bitset
3302       if (pr.tokStr = 'enum') or (pr.tokStr = 'bitset') then
3303       begin
3304         eb := TDynEBS.Create(pr);
3305         if (findEBSType(eb.typeName) <> nil) then
3306         begin
3307           eb.Free();
3308           raise TDynParseException.CreateFmt(pr, 'duplicate enum/bitset ''%s''', [eb.typeName]);
3309         end;
3310         eb.mOwner := self;
3311         ebsTypes.append(eb);
3312         //writeln(eb.definition); writeln;
3313         continue;
3314       end;
3315
3316       // triggerdata
3317       if (pr.tokStr = 'TriggerData') then
3318       begin
3319         rec := TDynRecord.Create(pr);
3320         for f := 0 to High(rec.mTrigTypes) do
3321         begin
3322           if (findTrigFor(rec.mTrigTypes[f]) <> nil) then
3323           begin
3324             rec.Free();
3325             raise TDynParseException.CreateFmt(pr, 'duplicate trigdata ''%s''', [rec.mTrigTypes[f]]);
3326           end;
3327         end;
3328         rec.mOwner := self;
3329         trigTypes.append(rec);
3330         //writeln(dr.definition); writeln;
3331         continue;
3332       end;
3333     end;
3334
3335     rec := TDynRecord.Create(pr);
3336     //writeln(dr.definition); writeln;
3337     if (findRecType(rec.typeName) <> nil) then begin rec.Free(); raise TDynParseException.CreateFmt(pr, 'duplicate record ''%s''', [rec.typeName]); end;
3338     if (hdr <> nil) and StrEqu(rec.typeName, hdr.typeName) then begin rec.Free(); raise TDynParseException.CreateFmt(pr, 'duplicate record ''%s''', [rec.typeName]); end;
3339     rec.mOwner := self;
3340     if rec.mHeader then
3341     begin
3342       if (hdr <> nil) then begin rec.Free(); raise TDynParseException.CreateFmt(pr, 'duplicate header record ''%s'' (previous is ''%s'')', [rec.typeName, hdr.typeName]); end;
3343       hdr := rec;
3344     end
3345     else
3346     begin
3347       recTypes.append(rec);
3348     end;
3349   end;
3350
3351   // put header record to top
3352   if (hdr = nil) then raise TDynParseException.Create(pr, 'header definition not found in mapdef');
3353   recTypes.append(nil);
3354   for f := recTypes.count-1 downto 1 do recTypes[f] := recTypes[f-1];
3355   recTypes[0] := hdr;
3356
3357   // setup header links and type links
3358   for rec in recTypes do linkRecord(rec);
3359   for rec in trigTypes do linkRecord(rec);
3360
3361   // setup default values
3362   for rec in recTypes do fixRecordDefaults(rec);
3363   for rec in trigTypes do fixRecordDefaults(rec);
3364 end;
3365
3366
3367 // ////////////////////////////////////////////////////////////////////////// //
3368 function TDynMapDef.parseTextMap (pr: TTextParser): TDynRecord;
3369 var
3370   res: TDynRecord = nil;
3371 begin
3372   result := nil;
3373   try
3374     pr.expectId(headerType.typeName);
3375     res := headerType.clone(nil);
3376     res.mHeaderRec := res;
3377     res.parseValue(pr);
3378     result := res;
3379     res := nil;
3380   finally
3381     res.Free();
3382   end;
3383 end;
3384
3385
3386 function TDynMapDef.parseBinMap (st: TStream): TDynRecord;
3387 var
3388   res: TDynRecord = nil;
3389 begin
3390   result := nil;
3391   try
3392     res := headerType.clone(nil);
3393     res.mHeaderRec := res;
3394     res.parseBinValue(st);
3395     result := res;
3396     res := nil;
3397   finally
3398     res.Free();
3399   end;
3400 end;
3401
3402
3403 // WARNING! stream must be seekable
3404 function TDynMapDef.parseMap (st: TStream): TDynRecord;
3405 var
3406   sign: packed array[0..3] of AnsiChar;
3407   pr: TTextParser;
3408 begin
3409   st.position := 0;
3410   st.ReadBuffer(sign[0], 4);
3411   st.position := 0;
3412   if (sign[0] = 'M') and (sign[1] = 'A') and (sign[2] = 'P') then
3413   begin
3414     if (sign[3] = #1) then
3415     begin
3416       result := parseBinMap(st);
3417       exit;
3418     end;
3419     raise TDynRecException.Create('invalid binary map version');
3420   end
3421   else
3422   begin
3423     pr := TFileTextParser.Create(st, false); // `st` is not owned
3424     try
3425       try
3426         result := parseTextMap(pr);
3427       except on e: Exception do
3428         raise TDynParseException.Create(pr, e.message);
3429       end;
3430     finally
3431       pr.Free();
3432     end;
3433   end;
3434 end;
3435
3436
3437 // returns `true` if the given stream can be a map file
3438 // stream position is 0 on return
3439 // WARNING! stream must be seekable
3440 class function TDynMapDef.canBeMap (st: TStream): Boolean;
3441 var
3442   sign: packed array[0..3] of AnsiChar;
3443   pr: TTextParser;
3444 begin
3445   result := false;
3446   st.position := 0;
3447   st.ReadBuffer(sign[0], 4);
3448   if (sign[0] = 'M') and (sign[1] = 'A') and (sign[2] = 'P') then
3449   begin
3450     result := (sign[3] = #1);
3451   end
3452   else
3453   begin
3454     st.position := 0;
3455     pr := TFileTextParser.Create(st, false); // `st` is not owned
3456     result := (pr.tokType = pr.TTId) and (pr.tokStr = 'map');
3457     pr.Free();
3458   end;
3459   st.position := 0;
3460 end;
3461
3462
3463 function TDynMapDef.pasdefconst (): AnsiString;
3464 var
3465   ebs: TDynEBS;
3466 begin
3467   result := '';
3468   result += '// ////////////////////////////////////////////////////////////////////////// //'#10;
3469   result += '// enums and bitsets'#10;
3470   for ebs in ebsTypes do result += #10+ebs.pasdef();
3471 end;
3472
3473
3474 function TDynMapDef.getRecTypeCount (): Integer; inline; begin result := recTypes.count; end;
3475 function TDynMapDef.getRecTypeAt (idx: Integer): TDynRecord; inline; begin if (idx >= 0) and (idx < recTypes.count) then result := recTypes[idx] else result := nil; end;
3476
3477 function TDynMapDef.getEBSTypeCount (): Integer; inline; begin result := ebsTypes.count; end;
3478 function TDynMapDef.getEBSTypeAt (idx: Integer): TDynEBS; inline; begin if (idx >= 0) and (idx < ebsTypes.count) then result := ebsTypes[idx] else result := nil; end;
3479
3480 function TDynMapDef.getTrigTypeCount (): Integer; inline; begin result := trigTypes.count; end;
3481 function TDynMapDef.getTrigTypeAt (idx: Integer): TDynRecord; inline; begin if (idx >= 0) and (idx < trigTypes.count) then result := trigTypes[idx] else result := nil; end;
3482
3483
3484 end.