DEADSOFTWARE

trigger loading now works; map loading code cleanup
[d2df-sdl.git] / 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;
20 interface
22 uses
23 Classes,
24 xparser, xstreams, utils, hashtable;
27 // ////////////////////////////////////////////////////////////////////////// //
28 type
29 TDynMapDef = class;
30 TDynRecord = class;
31 TDynField = class;
32 TDynEBS = class;
34 TDynFieldList = specialize TSimpleList<TDynField>;
35 TDynRecList = specialize TSimpleList<TDynRecord>;
36 TDynEBSList = specialize TSimpleList<TDynEBS>;
38 // this is base type for all scalars (and arrays)
39 TDynField = class
40 public
41 type
42 TType = (TBool, TChar, TByte, TUByte, TShort, TUShort, TInt, TUInt, TString, TPoint, TSize, TList, TTrigData);
43 // TPoint: pair of Integers
44 // TSize: pair of UShorts
45 // TList: actually, array of records
46 // TTrigData: array of mMaxDim bytes, but internally a record (mRecRef)
47 // arrays of chars are pascal shortstrings (with counter in the first byte)
49 private
50 type
51 TEBS = (TNone, TRec, TEnum, TBitSet);
53 private
54 mOwner: TDynRecord;
55 mPasName: AnsiString;
56 mName: AnsiString;
57 mType: TType;
58 mIVal: Integer; // for all integer types
59 mIVal2: Integer; // for point and size
60 mSVal: AnsiString; // string; for byte and char arrays
61 mRVal: TDynRecList; // for list
62 mRHash: THashStrInt; // id -> index in mRVal
63 mRecRef: TDynRecord; // for TEBS.TRec
64 mMaxDim: Integer; // for byte and char arrays; <0: not an array; 0: impossible value
65 mBinOfs: Integer; // offset in binary; <0 - none
66 mSepPosSize: Boolean; // for points and sizes, use separate fields
67 mAsT: Boolean; // for points and sizes, use separate fields, names starts with `t`
68 mDefined: Boolean;
69 mHasDefault: Boolean;
70 mOmitDef: Boolean;
71 mInternal: Boolean;
72 mNegBool: Boolean;
73 mBitSetUnique: Boolean; // bitset can contain only one value
74 mAsMonsterId: Boolean; // special hack for triggers: monster record number+1 in binary (so 0 means "none")
75 // default value
76 mDefUnparsed: AnsiString;
77 mDefSVal: AnsiString; // default string value
78 mDefIVal, mDefIVal2: Integer; // default integer values
79 mDefRecRef: TDynRecord;
80 mEBS: TEBS; // complex type type
81 mEBSTypeName: AnsiString; // name of enum, bitset or record
82 mEBSType: TObject; // either TDynRecord or TDynEBS; nil means "simple type"; nil for `TTrigData` too
84 // for binary parser
85 mRecRefId: AnsiString;
87 // for userdata
88 mTagInt: Integer;
89 mTagPtr: Pointer;
91 private
92 procedure cleanup ();
94 procedure parseDef (pr: TTextParser);
96 procedure parseDefaultValue (); // parse `mDefUnparsed` to `mDefSVal`, `mDefIVal`, `mDefIVal2`, `mDefRecRef`
97 procedure fixDefaultValue (); // this will NOT clone `mDefRecRef`
98 function isDefaultValue (): Boolean;
100 function getListCount (): Integer; inline;
101 function getListItem (idx: Integer): TDynRecord; inline; overload;
102 function getListItem (const aname: AnsiString): TDynRecord; inline; overload;
104 function getRecRefIndex (): Integer;
106 procedure setIVal (v: Integer); inline;
108 protected
109 // returns `true` for duplicate record id
110 function addListItem (rec: TDynRecord): Boolean; inline;
112 public
114 type
115 TListEnumerator = record
116 private
117 mList: TDynRecList;
118 mCurIdx: Integer;
119 public
120 constructor Create (alist: TDynRecList);
121 function MoveNext (): Boolean; inline;
122 function getCurrent (): TDynRecord; inline;
123 property Current: TDynRecord read getCurrent;
124 end;
127 public
128 constructor Create (const aname: AnsiString; atype: TType);
129 constructor Create (pr: TTextParser);
130 destructor Destroy (); override;
132 class function getTypeName (t: TType): AnsiString;
134 function definition (): AnsiString;
135 function pasdef (): AnsiString;
137 function clone (newOwner: TDynRecord=nil): TDynField;
139 procedure parseValue (pr: TTextParser);
140 procedure parseBinValue (st: TStream);
142 procedure writeTo (wr: TTextWriter);
143 procedure writeBinTo (st: TStream);
145 // won't work for lists
146 function isSimpleEqu (fld: TDynField): Boolean;
148 procedure setValue (const s: AnsiString);
150 function GetEnumerator (): TDynRecList.TEnumerator; inline;
152 public
153 property pasname: AnsiString read mPasName;
154 property name: AnsiString read mName;
155 property baseType: TType read mType;
156 property negbool: Boolean read mNegBool;
157 property defined: Boolean read mDefined write mDefined;
158 property internal: Boolean read mInternal write mInternal;
159 property hasTPrefix: Boolean read mAsT;
160 property separatePasFields: Boolean read mSepPosSize;
161 property binOfs: Integer read mBinOfs;
162 property ival: Integer read mIVal write setIVal;
163 property ival2: Integer read mIVal2;
164 property sval: AnsiString read mSVal;
165 property hasDefault: Boolean read mHasDefault;
166 property defsval: AnsiString read mDefSVal;
167 property ebs: TEBS read mEBS;
168 property ebstype: TObject read mEBSType;
169 property ebstypename: AnsiString read mEBSTypeName; // enum/bitset name
170 property recref: TDynRecord read mRecRef write mRecRef; //FIXME: writing is a hack!
171 property recrefIndex: Integer read getRecRefIndex; // search for this record in header; -1: not found
172 // for lists
173 property count: Integer read getListCount;
174 property item[idx: Integer]: TDynRecord read getListItem;
175 property items[const aname: AnsiString]: TDynRecord read getListItem; default; // alas, FPC 3+ lost property overloading feature
176 // userdata
177 property tagInt: Integer read mTagInt write mTagInt;
178 property tagPtr: Pointer read mTagPtr write mTagPtr;
179 end;
182 // "value" header record contains TList fields, with name equal to record type
183 TDynRecord = class
184 private
185 mOwner: TDynMapDef;
186 mId: AnsiString;
187 mPasName: AnsiString;
188 mName: AnsiString;
189 mSize: Integer;
190 mFields: TDynFieldList;
191 {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
192 mFieldsHash: THashStrInt; // id -> index in mRVal
193 {$ENDIF}
194 mTrigTypes: array of AnsiString; // if this is triggerdata, we'll hold list of triggers here
195 mHeader: Boolean; // true for header record
196 mBinBlock: Integer; // -1: none
197 mHeaderRec: TDynRecord; // for "value" records this is header record with data, for "type" records this is header type record
199 // for userdata
200 mTagInt: Integer;
201 mTagPtr: Pointer;
203 private
204 procedure parseDef (pr: TTextParser); // parse definition
206 function findByName (const aname: AnsiString): Integer; inline;
207 function hasByName (const aname: AnsiString): Boolean; inline;
208 function getFieldByName (const aname: AnsiString): TDynField; inline;
209 function getFieldAt (idx: Integer): TDynField; inline;
210 function getCount (): Integer; inline;
212 function getIsTrigData (): Boolean; inline;
213 function getIsForTrig (const aname: AnsiString): Boolean; inline;
215 function getForTrigCount (): Integer; inline;
216 function getForTrigAt (idx: Integer): AnsiString; inline;
218 protected
219 function findRecordByTypeId (const atypename, aid: AnsiString): TDynRecord;
220 function findRecordNumByType (const atypename: AnsiString; rc: TDynRecord): Integer;
221 function addRecordByType (const atypename: AnsiString; rc: TDynRecord): Boolean; // `true`: duplicate record id
223 procedure addField (fld: TDynField); inline;
224 function addFieldChecked (fld: TDynField): Boolean; inline; // `true`: duplicate name
226 public
227 constructor Create ();
228 constructor Create (pr: TTextParser); // parse definition
229 destructor Destroy (); override;
231 function definition (): AnsiString;
232 function pasdef (): AnsiString;
234 function clone (): TDynRecord;
236 function isSimpleEqu (rec: TDynRecord): Boolean;
238 procedure parseValue (pr: TTextParser; beginEaten: Boolean=false);
239 procedure parseBinValue (st: TStream; forceData: Boolean=false);
241 procedure writeTo (wr: TTextWriter; putHeader: Boolean=true);
242 procedure writeBinTo (st: TStream; trigbufsz: Integer=-1; onlyFields: Boolean=false);
244 // find field with `TriggerType` type
245 function trigTypeField (): TDynField;
247 // number of records of the given instance
248 function instanceCount (const typename: AnsiString): Integer;
250 procedure setUserField (const fldname: AnsiString; v: LongInt);
251 procedure setUserField (const fldname: AnsiString; v: AnsiString);
253 public
254 property id: AnsiString read mId; // for map parser
255 property pasname: AnsiString read mPasName;
256 property name: AnsiString read mName; // record name
257 property size: Integer read mSize; // size in bytes
258 //property fields: TDynFieldList read mFields;
259 property has[const aname: AnsiString]: Boolean read hasByName;
260 property count: Integer read getCount;
261 property field[const aname: AnsiString]: TDynField read getFieldByName; default;
262 property fieldAt[idx: Integer]: TDynField read getFieldAt;
263 property isTrigData: Boolean read getIsTrigData;
264 property isForTrig[const aname: AnsiString]: Boolean read getIsForTrig;
265 property forTrigCount: Integer read getForTrigCount;
266 property forTrigAt[idx: Integer]: AnsiString read getForTrigAt;
267 property headerRec: TDynRecord read mHeaderRec;
268 property isHeader: Boolean read mHeader;
269 // userdata
270 property tagInt: Integer read mTagInt write mTagInt;
271 property tagPtr: Pointer read mTagPtr write mTagPtr;
272 end;
274 TDynEBS = class
275 private
276 mOwner: TDynMapDef;
277 mIsEnum: Boolean;
278 mName: AnsiString;
279 mIds: array of AnsiString;
280 mVals: array of Integer;
281 mMaxName: AnsiString; // MAX field
282 mMaxVal: Integer; // max value
284 private
285 procedure cleanup ();
287 procedure parseDef (pr: TTextParser); // parse definition
289 function findByName (const aname: AnsiString): Integer; inline;
290 function hasByName (const aname: AnsiString): Boolean; inline;
291 function getFieldByName (const aname: AnsiString): Integer; inline;
293 public
294 constructor Create (pr: TTextParser); // parse definition
295 destructor Destroy (); override;
297 function definition (): AnsiString;
298 function pasdef (): AnsiString;
300 // return empty string if not found
301 function nameByValue (v: Integer): AnsiString;
303 public
304 property name: AnsiString read mName; // record name
305 property isEnum: Boolean read mIsEnum;
306 property has[const aname: AnsiString]: Boolean read hasByName;
307 property field[const aname: AnsiString]: Integer read getFieldByName;
308 end;
311 TDynMapDef = class
312 public
313 recTypes: TDynRecList; // [0] is always header
314 trigTypes: TDynRecList; // trigdata
315 ebsTypes: TDynEBSList; // enums, bitsets
317 private
318 procedure parseDef (pr: TTextParser);
320 function getHeaderRecType (): TDynRecord; inline;
322 function getTrigTypeCount (): Integer; inline;
323 function getTrigTypeAt (idx: Integer): TDynRecord; inline;
325 public
326 constructor Create (pr: TTextParser); // parses data definition
327 destructor Destroy (); override;
329 function findRecType (const aname: AnsiString): TDynRecord;
330 function findTrigFor (const aname: AnsiString): TDynRecord;
331 function findEBSType (const aname: AnsiString): TDynEBS;
333 function pasdef (): AnsiString;
334 function pasdefconst (): AnsiString;
336 // creates new header record
337 function parseMap (pr: TTextParser): TDynRecord;
339 // creates new header record
340 function parseBinMap (st: TStream): TDynRecord;
342 public
343 property headerType: TDynRecord read getHeaderRecType;
344 property trigTypeCount: Integer read getTrigTypeCount;
345 property trigType[idx: Integer]: TDynRecord read getTrigTypeAt;
346 end;
349 {$IF DEFINED(D2D_DYNREC_PROFILER)}
350 procedure xdynDumpProfiles ();
351 {$ENDIF}
354 implementation
356 uses
357 SysUtils, e_log
358 {$IF DEFINED(D2D_DYNREC_PROFILER)},xprofiler{$ENDIF};
361 // ////////////////////////////////////////////////////////////////////////// //
362 function StrEqu (const a, b: AnsiString): Boolean; inline; begin result := (a = b); end;
365 // ////////////////////////////////////////////////////////////////////////// //
367 constructor TDynField.TListEnumerator.Create (alist: TDynRecList);
368 begin
369 mList := alist;
370 mCurIdx := -1;
371 end;
374 function TDynField.TListEnumerator.MoveNext (): Boolean; inline;
375 begin
376 Inc(mCurIdx);
377 result := (mList <> nil) and (mCurIdx < mList.count);
378 end;
381 function TDynField.TListEnumerator.getCurrent (): TDynRecord; inline;
382 begin
383 result := mList[mCurIdx];
384 end;
388 function TDynField.GetEnumerator (): TDynRecList.TEnumerator; inline;
389 begin
390 //result := TListEnumerator.Create(mRVal);
391 if (mRVal <> nil) then result := mRVal.GetEnumerator else result := TDynRecList.TEnumerator.Create(nil, 0);
392 end;
395 // ////////////////////////////////////////////////////////////////////////// //
396 constructor TDynField.Create (const aname: AnsiString; atype: TType);
397 begin
398 mRVal := nil;
399 mRecRef := nil;
400 mRHash := nil;
401 cleanup();
402 mName := aname;
403 mType := atype;
404 if (mType = TType.TList) then
405 begin
406 mRVal := TDynRecList.Create();
407 mRHash := hashNewStrInt();
408 end;
409 end;
412 constructor TDynField.Create (pr: TTextParser);
413 begin
414 cleanup();
415 parseDef(pr);
416 end;
419 destructor TDynField.Destroy ();
420 begin
421 cleanup();
422 inherited;
423 end;
426 procedure TDynField.cleanup ();
427 begin
428 mName := '';
429 mType := TType.TInt;
430 mIVal := 0;
431 mIVal2 := 0;
432 mSVal := '';
433 mRVal.Free();
434 mRVal := nil;
435 mRHash.Free();
436 mRHash := nil;
437 mRecRef := nil;
438 mMaxDim := -1;
439 mBinOfs := -1;
440 mSepPosSize := false;
441 mAsT := false;
442 mHasDefault := false;
443 mDefined := false;
444 mOmitDef := false;
445 mInternal := true;
446 mDefUnparsed := '';
447 mDefSVal := '';
448 mDefIVal := 0;
449 mDefIVal2 := 0;
450 mDefRecRef := nil;
451 mEBS := TEBS.TNone;
452 mEBSTypeName := '';
453 mEBSType := nil;
454 mBitSetUnique := false;
455 mAsMonsterId := false;
456 mNegBool := false;
457 mRecRefId := '';
458 mTagInt := 0;
459 mTagPtr := nil;
460 end;
463 function TDynField.clone (newOwner: TDynRecord=nil): TDynField;
464 var
465 rec: TDynRecord;
466 begin
467 result := TDynField.Create(mName, mType);
468 result.mOwner := mOwner;
469 if (newOwner <> nil) then result.mOwner := newOwner else result.mOwner := mOwner;
470 result.mPasName := mPasName;
471 result.mName := mName;
472 result.mType := mType;
473 result.mIVal := mIVal;
474 result.mIVal2 := mIVal2;
475 result.mSVal := mSVal;
476 if (mRVal <> nil) then
477 begin
478 if (result.mRVal = nil) then result.mRVal := TDynRecList.Create(mRVal.count);
479 if (result.mRHash = nil) then result.mRHash := hashNewStrInt();
480 for rec in mRVal do result.addListItem(rec.clone());
481 end;
482 result.mRecRef := mRecRef;
483 result.mMaxDim := mMaxDim;
484 result.mBinOfs := mBinOfs;
485 result.mSepPosSize := mSepPosSize;
486 result.mAsT := mAsT;
487 result.mDefined := mDefined;
488 result.mHasDefault := mHasDefault;
489 result.mOmitDef := mOmitDef;
490 result.mInternal := mInternal;
491 result.mNegBool := mNegBool;
492 result.mBitSetUnique := mBitSetUnique;
493 result.mAsMonsterId := mAsMonsterId;
494 result.mDefUnparsed := mDefUnparsed;
495 result.mDefSVal := mDefSVal;
496 result.mDefIVal := mDefIVal;
497 result.mDefIVal2 := mDefIVal2;
498 result.mDefRecRef := mDefRecRef;
499 result.mEBS := mEBS;
500 result.mEBSTypeName := mEBSTypeName;
501 result.mEBSType := mEBSType;
502 result.mRecRefId := mRecRefId;
503 result.mTagInt := mTagInt;
504 result.mTagPtr := mTagPtr;
505 end;
508 procedure TDynField.setIVal (v: Integer); inline;
509 begin
510 //FIXME: check type
511 mIVal := v;
512 mDefined := true;
513 end;
516 // won't work for lists
517 function TDynField.isSimpleEqu (fld: TDynField): Boolean;
518 begin
519 if (fld = nil) or (mType <> fld.mType) then begin result := false; exit; end;
520 case mType of
521 TType.TBool: result := ((mIVal <> 0) = (fld.mIVal <> 0));
522 TType.TChar: result := (mSVal = fld.mSVal);
523 TType.TByte,
524 TType.TUByte,
525 TType.TShort,
526 TType.TUShort,
527 TType.TInt,
528 TType.TUInt:
529 result := (mIVal = fld.mIVal);
530 TType.TString: result := (mSVal = fld.mSVal);
531 TType.TPoint,
532 TType.TSize:
533 result := ((mIVal = fld.mIVal) and (mIVal2 = fld.mIVal2));
534 TType.TList: result := false;
535 TType.TTrigData:
536 begin
537 if (mRecRef = nil) then begin result := (fld.mRecRef = nil); exit; end;
538 result := mRecRef.isSimpleEqu(fld.mRecRef);
539 end;
540 else raise Exception.Create('ketmar forgot to handle some field type');
541 end;
542 end;
545 procedure TDynField.setValue (const s: AnsiString);
546 var
547 stp: TTextParser;
548 begin
549 stp := TStrTextParser.Create(s+';');
550 try
551 parseValue(stp);
552 finally
553 stp.Free();
554 end;
555 end;
558 procedure TDynField.parseDefaultValue ();
559 var
560 stp: TTextParser = nil;
561 oSVal: AnsiString;
562 oIVal, oIVal2: Integer;
563 oRRef: TDynRecord;
564 oDef: Boolean;
565 begin
566 if not mHasDefault then
567 begin
568 mDefSVal := '';
569 mDefIVal := 0;
570 mDefIVal2 := 0;
571 mDefRecRef := nil;
572 end
573 else
574 begin
575 oSVal := mSVal;
576 oIVal := mIVal;
577 oIVal2 := mIVal2;
578 oRRef := mRecRef;
579 oDef := mDefined;
580 try
581 stp := TStrTextParser.Create(mDefUnparsed+';');
582 parseValue(stp);
583 mDefSVal := mSVal;
584 mDefIVal := mIVal;
585 mDefIVal2 := mIVal2;
586 mDefRecRef := mRecRef;
587 finally
588 mSVal := oSVal;
589 mIVal := oIVal;
590 mIVal2 := oIVal2;
591 mRecRef := oRRef;
592 mDefined := oDef;
593 stp.Free();
594 end;
595 end;
596 end;
599 // default value should be parsed
600 procedure TDynField.fixDefaultValue ();
601 begin
602 if mDefined then exit;
603 if not mHasDefault then
604 begin
605 if mInternal then exit;
606 raise Exception.Create(Format('field ''%s'' in record ''%s'' of record type ''%s'' is not set', [mName, mOwner.mId, mOwner.mName]));
607 end;
608 if (mEBS = TEBS.TRec) then mRecRef := mDefRecRef;
609 mSVal := mDefSVal;
610 mIVal := mDefIVal;
611 mIVal2 := mDefIVal2;
612 mDefined := true;
613 end;
616 // default value should be parsed
617 function TDynField.isDefaultValue (): Boolean;
618 begin
619 if not mHasDefault then begin result := false; exit; end;
620 if (mEBS = TEBS.TRec) then begin result := (mRecRef = mDefRecRef); exit; end;
621 case mType of
622 TType.TChar, TType.TString: result := (mSVal = mDefSVal);
623 TType.TPoint, TType.TSize: result := (mIVal = mDefIVal2) and (mIVal2 = mDefIVal2);
624 TType.TList, TType.TTrigData: result := false; // no default values for those types
625 else result := (mIVal = mDefIVal);
626 end;
627 end;
630 function TDynField.getListCount (): Integer; inline;
631 begin
632 if (mRVal <> nil) then result := mRVal.count else result := 0;
633 end;
636 function TDynField.getListItem (idx: Integer): TDynRecord; inline; overload;
637 begin
638 if (mRVal <> nil) and (idx >= 0) and (idx < mRVal.count) then result := mRVal[idx] else result := nil;
639 end;
642 function TDynField.getListItem (const aname: AnsiString): TDynRecord; inline; overload;
643 var
644 idx: Integer;
645 begin
646 if (mRVal <> nil) and mRHash.get(aname, idx) then result := mRVal[idx] else result := nil;
647 end;
650 function TDynField.addListItem (rec: TDynRecord): Boolean; inline;
651 begin
652 result := false;
653 if (mRVal <> nil) then
654 begin
655 mRVal.append(rec);
656 if (Length(rec.mId) > 0) then result := mRHash.put(rec.mId, mRVal.count-1);
657 end;
658 end;
661 class function TDynField.getTypeName (t: TType): AnsiString;
662 begin
663 case t of
664 TType.TBool: result := 'bool';
665 TType.TChar: result := 'char';
666 TType.TByte: result := 'byte';
667 TType.TUByte: result := 'ubyte';
668 TType.TShort: result := 'short';
669 TType.TUShort: result := 'ushort';
670 TType.TInt: result := 'int';
671 TType.TUInt: result := 'uint';
672 TType.TString: result := 'string';
673 TType.TPoint: result := 'point';
674 TType.TSize: result := 'size';
675 TType.TList: result := 'array';
676 TType.TTrigData: result := 'trigdata';
677 else raise Exception.Create('ketmar forgot to handle some field type');
678 end;
679 end;
682 function TDynField.definition (): AnsiString;
683 begin
684 result := mPasName+' is '+quoteStr(mName)+' type ';
685 result += getTypeName(mType);
686 if (mMaxDim >= 0) then result += Format('[%d]', [mMaxDim]);
687 if (mBinOfs >= 0) then result += Format(' offset %d', [mBinOfs]);
688 case mEBS of
689 TEBS.TNone: begin end;
690 TEBS.TRec: result += ' '+mEBSTypeName;
691 TEBS.TEnum: result += ' enum '+mEBSTypeName;
692 TEBS.TBitSet: begin result += ' bitset '; if mBitSetUnique then result += 'unique '; result += mEBSTypeName; end;
693 end;
694 if mAsMonsterId then result += ' as monsterid';
695 if mHasDefault and (Length(mDefUnparsed) > 0) then result += ' default '+mDefUnparsed;
696 if mSepPosSize then
697 begin
698 if (mType = TType.TPoint) then begin if (mAsT) then result += ' as txy' else result += ' as xy'; end
699 else if (mType = TType.TSize) then begin if (mAsT) then result += ' as twh' else result += ' as wh'; end;
700 end;
701 if mOmitDef then result += ' omitdefault';
702 if mInternal then result += ' internal';
703 end;
706 function TDynField.pasdef (): AnsiString;
707 begin
708 result := mPasName+': ';
709 case mType of
710 TType.TBool: result += 'Boolean;';
711 TType.TChar: if (mMaxDim > 0) then result += formatstrf('Char%d;', [mMaxDim]) else result += 'Char;';
712 TType.TByte: result += 'ShortInt;';
713 TType.TUByte: result += 'Byte;';
714 TType.TShort: result += 'SmallInt;';
715 TType.TUShort: result += 'Word;';
716 TType.TInt: result += 'LongInt;';
717 TType.TUInt: result += 'LongWord;';
718 TType.TString: result += 'AnsiString;';
719 TType.TPoint:
720 if mAsT then result := 'tX, tY: Integer;'
721 else if mSepPosSize then result := 'X, Y: Integer;'
722 else result += 'TDFPoint;';
723 TType.TSize:
724 if mAsT then result := 'tWidth, tHeight: Word;'
725 else if mSepPosSize then result := 'Width, Height: Word;'
726 else result += 'TSize;';
727 TType.TList: assert(false);
728 TType.TTrigData: result += formatstrf('Byte%d;', [mMaxDim]);
729 else raise Exception.Create('ketmar forgot to handle some field type');
730 end;
731 end;
734 procedure TDynField.parseDef (pr: TTextParser);
735 var
736 fldname: AnsiString;
737 fldtype: AnsiString;
738 fldofs: Integer;
739 fldrecname: AnsiString;
740 fldpasname: AnsiString;
741 asxy, aswh, ast: Boolean;
742 ainternal: Boolean;
743 omitdef: Boolean;
744 defstr: AnsiString;
745 defint: Integer;
746 hasdefStr: Boolean;
747 hasdefInt: Boolean;
748 hasdefId: Boolean;
749 lmaxdim: Integer;
750 lebs: TDynField.TEBS;
751 unique: Boolean;
752 asmonid: Boolean;
753 begin
754 fldpasname := '';
755 fldname := '';
756 fldtype := '';
757 fldofs := -1;
758 fldrecname := '';
759 asxy := false;
760 aswh := false;
761 ast := false;
762 ainternal := false;
763 omitdef := false;
764 defstr := '';
765 defint := 0;
766 hasdefStr := false;
767 hasdefInt := false;
768 hasdefId := false;
769 unique := false;
770 asmonid := false;
771 lmaxdim := -1;
772 lebs := TDynField.TEBS.TNone;
774 fldpasname := pr.expectId(); // pascal field name
775 // field name
776 pr.expectId('is');
777 fldname := pr.expectStr();
778 // field type
779 pr.expectId('type');
780 fldtype := pr.expectId();
782 // fixed-size array?
783 if pr.eatDelim('[') then
784 begin
785 lmaxdim := pr.expectInt();
786 if (lmaxdim < 1) then raise Exception.Create(Format('invalid field ''%s'' array size', [fldname]));
787 pr.expectDelim(']');
788 end;
790 while (pr.tokType <> pr.TTSemi) do
791 begin
792 if pr.eatId('offset') then
793 begin
794 if (fldofs >= 0) then raise Exception.Create(Format('duplicate field ''%s'' offset', [fldname]));
795 fldofs := pr.expectInt();
796 if (fldofs < 0) then raise Exception.Create(Format('invalid field ''%s'' offset', [fldname]));
797 continue;
798 end;
800 if pr.eatId('as') then
801 begin
802 if pr.eatId('xy') then asxy := true
803 else if pr.eatId('wh') then aswh := true
804 else if pr.eatId('txy') then begin asxy := true; ast := true; end
805 else if pr.eatId('twh') then begin aswh := true; ast := true; end
806 else if pr.eatId('monsterid') then begin asmonid := true; end
807 else raise Exception.Create(Format('invalid field ''%s'' as what?', [fldname]));
808 continue;
809 end;
811 if pr.eatId('enum') then
812 begin
813 lebs := TDynField.TEBS.TEnum;
814 if (Length(fldrecname) <> 0) then raise Exception.Create(Format('field ''%s'' already typed as ''%s''', [fldname, fldrecname]));
815 fldrecname := pr.expectId();
816 continue;
817 end;
819 if pr.eatId('bitset') then
820 begin
821 lebs := TDynField.TEBS.TBitSet;
822 if (Length(fldrecname) <> 0) then raise Exception.Create(Format('field ''%s'' already typed as ''%s''', [fldname, fldrecname]));
823 unique := pr.eatId('unique');
824 fldrecname := pr.expectId();
825 continue;
826 end;
828 if pr.eatId('default') then
829 begin
830 if hasdefStr or hasdefInt or hasdefId then raise Exception.Create(Format('field ''%s'' has duplicate default', [fldname]));
831 case pr.tokType of
832 pr.TTStr:
833 begin
834 hasdefStr := true;
835 defstr := pr.expectStr(true); // allow empty strings
836 end;
837 pr.TTId:
838 begin
839 hasdefId := true;
840 defstr := pr.expectId();
841 end;
842 pr.TTInt:
843 begin
844 hasdefInt := true;
845 defint := pr.expectInt();
846 end;
847 else
848 raise Exception.Create(Format('field ''%s'' has invalid default', [fldname]));
849 end;
850 continue;
851 end;
853 if pr.eatId('omitdefault') then
854 begin
855 omitdef := true;
856 continue;
857 end;
859 if pr.eatId('internal') then
860 begin
861 ainternal := true;
862 continue;
863 end;
865 if (pr.tokType <> pr.TTId) then raise Exception.Create(Format('field ''%s'' has something unexpected in definition', [fldname]));
867 if (Length(fldrecname) <> 0) then raise Exception.Create(Format('field ''%s'' already typed as ''%s''', [fldname, fldrecname]));
868 fldrecname := pr.expectId();
869 lebs := TDynField.TEBS.TRec;
870 end;
872 pr.expectTT(pr.TTSemi);
874 // create field
875 mName := fldname;
876 if (fldtype = 'bool') then mType := TType.TBool
877 else if (fldtype = 'negbool') then begin mType := TType.TBool; mNegBool := true; end
878 else if (fldtype = 'char') then mType := TType.TChar
879 else if (fldtype = 'byte') then mType := TType.TByte
880 else if (fldtype = 'ubyte') then mType := TType.TUByte
881 else if (fldtype = 'short') then mType := TType.TShort
882 else if (fldtype = 'ushort') then mType := TType.TUShort
883 else if (fldtype = 'int') then mType := TType.TInt
884 else if (fldtype = 'uint') then mType := TType.TUInt
885 else if (fldtype = 'string') then mType := TType.TString
886 else if (fldtype = 'point') then mType := TType.TPoint
887 else if (fldtype = 'size') then mType := TType.TSize
888 else if (fldtype = 'trigdata') then mType := TType.TTrigData
889 else raise Exception.Create(Format('field ''%s'' has invalid type ''%s''', [fldname, fldtype]));
891 if (lmaxdim > 0) and (mType <> TType.TChar) and (mType <> TType.TTrigData) then raise Exception.Create(Format('field ''%s'' of type ''%s'' cannot be array', [fldname, fldtype]));
892 if (mType = TType.TTrigData) then
893 begin
894 if (lmaxdim < 1) then raise Exception.Create(Format('field ''%s'' of type ''%s'' cannot be array', [fldname, fldtype]));
895 if (Length(fldrecname) > 0) then raise Exception.Create(Format('field ''%s'' of type ''%s'' cannot have another type', [fldname, fldtype]));
896 lebs := TDynField.TEBS.TRec;
897 end;
899 if hasdefStr then self.mDefUnparsed := quoteStr(defstr)
900 else if hasdefInt then self.mDefUnparsed := Format('%d', [defint])
901 else if hasdefId then self.mDefUnparsed := defstr;
903 self.mHasDefault := (hasdefStr or hasdefId or hasdefInt);
904 self.mPasName := fldpasname;
905 self.mEBS := lebs;
906 self.mEBSTypeName := fldrecname;
907 self.mBitSetUnique := unique;
908 self.mAsMonsterId := asmonid;
909 self.mMaxDim := lmaxdim;
910 self.mBinOfs := fldofs;
911 self.mSepPosSize := (asxy or aswh);
912 self.mAsT := ast;
913 self.mOmitDef := omitdef;
914 self.mInternal := ainternal;
915 end;
918 function TDynField.getRecRefIndex (): Integer;
919 begin
920 if (mRecRef = nil) then begin result := -1; exit; end;
921 result := mOwner.findRecordNumByType(mEBSTypeName, mRecRef);
922 end;
925 procedure TDynField.writeBinTo (st: TStream);
926 var
927 s: AnsiString;
928 f: Integer;
929 maxv: Integer;
930 buf: PByte;
931 ws: TStream = nil;
932 begin
933 case mEBS of
934 TEBS.TNone: begin end;
935 TEBS.TRec:
936 begin
937 if (mMaxDim >= 0) then
938 begin
939 // this must be triggerdata
940 if (mType <> TType.TTrigData) then
941 begin
942 raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName]));
943 end;
944 // write triggerdata
945 GetMem(buf, mMaxDim);
946 if (buf = nil) then raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName]));
947 try
948 FillChar(buf^, mMaxDim, 0);
949 if (mRecRef <> nil) then
950 begin
951 ws := TSFSMemoryChunkStream.Create(buf, mMaxDim);
952 mRecRef.writeBinTo(ws, mMaxDim); // as trigdata
953 end;
954 st.WriteBuffer(buf^, mMaxDim);
955 finally
956 ws.Free();
957 if (buf <> nil) then FreeMem(buf);
958 end;
959 exit;
960 end;
961 // record reference
962 case mType of
963 TType.TByte: maxv := 127;
964 TType.TUByte: maxv := 254;
965 TType.TShort: maxv := 32767;
966 TType.TUShort: maxv := 65534;
967 TType.TInt: maxv := $7fffffff;
968 TType.TUInt: maxv := $7fffffff;
969 else raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName]));
970 end;
971 // find record number
972 if (mRecRef <> nil) then
973 begin
974 f := mOwner.findRecordNumByType(mEBSTypeName, mRecRef);
975 if (f < 0) then raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' not found in record list', [mEBSTypeName, mName]));
976 if mAsMonsterId then Inc(f);
977 if (f > maxv) then raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' has too big index', [mEBSTypeName, mName]));
978 end
979 else
980 begin
981 if mAsMonsterId then f := 0 else f := -1;
982 end;
983 case mType of
984 TType.TByte, TType.TUByte: writeInt(st, Byte(f));
985 TType.TShort, TType.TUShort: writeInt(st, SmallInt(f));
986 TType.TInt, TType.TUInt: writeInt(st, LongWord(f));
987 else raise Exception.Create(Format('record reference type ''%s'' in field ''%s'' cannot be written', [mEBSTypeName, mName]));
988 end;
989 exit;
990 end;
991 TEBS.TEnum: begin end;
992 TEBS.TBitSet: begin end;
993 else raise Exception.Create('ketmar forgot to handle some EBS type');
994 end;
996 case mType of
997 TType.TBool:
998 begin
999 if not mNegBool then
1000 begin
1001 if (mIVal <> 0) then writeInt(st, Byte(1)) else writeInt(st, Byte(0));
1002 end
1003 else
1004 begin
1005 if (mIVal = 0) then writeInt(st, Byte(1)) else writeInt(st, Byte(0));
1006 end;
1007 exit;
1008 end;
1009 TType.TChar:
1010 begin
1011 if (mMaxDim = 0) then raise Exception.Create(Format('invalid string size definition for field ''%s''', [mName]));
1012 if (mMaxDim < 0) then
1013 begin
1014 if (Length(mSVal) <> 1) then raise Exception.Create(Format('invalid string size definition for field ''%s''', [mName]));
1015 writeInt(st, Byte(mSVal[1]));
1016 end
1017 else
1018 begin
1019 if (Length(mSVal) > mMaxDim) then raise Exception.Create(Format('invalid string size definition for field ''%s''', [mName]));
1020 s := utf2win(mSVal);
1021 if (Length(s) > 0) then st.WriteBuffer(PChar(s)^, Length(s));
1022 for f := Length(s) to mMaxDim do writeInt(st, Byte(0));
1023 end;
1024 exit;
1025 end;
1026 TType.TByte,
1027 TType.TUByte:
1028 begin
1029 // triggerdata array was processed earlier
1030 if (mMaxDim >= 0) then Exception.Create(Format('byte array in field ''%s'' cannot be written', [mName]));
1031 writeInt(st, Byte(mIVal));
1032 exit;
1033 end;
1034 TType.TShort,
1035 TType.TUShort:
1036 begin
1037 if (mMaxDim >= 0) then raise Exception.Create(Format('short array in field ''%s'' cannot be written', [mName]));
1038 writeInt(st, Word(mIVal));
1039 exit;
1040 end;
1041 TType.TInt,
1042 TType.TUInt:
1043 begin
1044 if (mMaxDim >= 0) then raise Exception.Create(Format('int array in field ''%s'' cannot be written', [mName]));
1045 writeInt(st, LongWord(mIVal));
1046 exit;
1047 end;
1048 TType.TString:
1049 begin
1050 raise Exception.Create(Format('cannot write string field ''%s''', [mName]));
1051 end;
1052 TType.TPoint:
1053 begin
1054 if (mMaxDim >= 0) then raise Exception.Create(Format('pos/size array in field ''%s'' cannot be written', [mName]));
1055 writeInt(st, LongInt(mIVal));
1056 writeInt(st, LongInt(mIVal2));
1057 exit;
1058 end;
1059 TType.TSize:
1060 begin
1061 if (mMaxDim >= 0) then raise Exception.Create(Format('pos/size array in field ''%s'' cannot be written', [mName]));
1062 writeInt(st, Word(mIVal));
1063 writeInt(st, Word(mIVal2));
1064 exit;
1065 end;
1066 TType.TList:
1067 begin
1068 assert(false);
1069 exit;
1070 end;
1071 TType.TTrigData:
1072 begin
1073 assert(false);
1074 exit;
1075 end;
1076 else raise Exception.Create('ketmar forgot to handle some field type');
1077 end;
1078 end;
1081 procedure TDynField.writeTo (wr: TTextWriter);
1082 var
1083 es: TDynEBS = nil;
1084 f, mask: Integer;
1085 first, found: Boolean;
1086 begin
1087 wr.put(mName);
1088 wr.put(' ');
1089 case mEBS of
1090 TEBS.TNone: begin end;
1091 TEBS.TRec:
1092 begin
1093 if (mRecRef = nil) then
1094 begin
1095 if (mType = TType.TTrigData) then wr.put('{}'#10) else wr.put('null;'#10);
1096 end
1097 else if (Length(mRecRef.mId) = 0) then
1098 begin
1099 mRecRef.writeTo(wr, false); // only data, no header
1100 end
1101 else
1102 begin
1103 wr.put(mRecRef.mId);
1104 wr.put(';'#10);
1105 end;
1106 exit;
1107 end;
1108 TEBS.TEnum:
1109 begin
1110 //def := mOwner.mOwner;
1111 //es := def.findEBSType(mEBSTypeName);
1112 es := nil;
1113 if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS);
1114 if (es = nil) or (not es.mIsEnum) then raise Exception.Create(Format('record enum type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]));
1115 for f := 0 to High(es.mVals) do
1116 begin
1117 if (es.mVals[f] = mIVal) then
1118 begin
1119 wr.put(es.mIds[f]);
1120 wr.put(';'#10);
1121 exit;
1122 end;
1123 end;
1124 raise Exception.Create(Format('value %d in record enum type ''%s'' for field ''%s'' not found', [mIVal, mEBSTypeName, mName]));
1125 end;
1126 TEBS.TBitSet:
1127 begin
1128 //def := mOwner.mOwner;
1129 //es := def.findEBSType(mEBSTypeName);
1130 es := nil;
1131 if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS);
1132 if (es = nil) or es.mIsEnum then raise Exception.Create(Format('record bitset type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]));
1133 // none?
1134 if (mIVal = 0) then
1135 begin
1136 for f := 0 to High(es.mVals) do
1137 begin
1138 if (es.mVals[f] = 0) then
1139 begin
1140 wr.put(es.mIds[f]);
1141 wr.put(';'#10);
1142 exit;
1143 end;
1144 end;
1145 raise Exception.Create(Format('value %d in record bitset type ''%s'' for field ''%s'' not found', [0, mEBSTypeName, mName]));
1146 end;
1147 // not none
1148 mask := 1;
1149 first := true;
1150 while (mask <> 0) do
1151 begin
1152 if ((mIVal and mask) <> 0) then
1153 begin
1154 found := false;
1155 for f := 0 to High(es.mVals) do
1156 begin
1157 if (es.mVals[f] = mask) then
1158 begin
1159 if not first then wr.put('+') else first := false;
1160 wr.put(es.mIds[f]);
1161 found := true;
1162 break;
1163 end;
1164 end;
1165 if not found then raise Exception.Create(Format('value %d in record bitset type ''%s'' for field ''%s'' not found', [mask, mEBSTypeName, mName]));
1166 end;
1167 mask := mask shl 1;
1168 end;
1169 wr.put(';'#10);
1170 exit;
1171 end;
1172 else raise Exception.Create('ketmar forgot to handle some EBS type');
1173 end;
1175 case mType of
1176 TType.TBool:
1177 begin
1178 if (mIVal = 0) then wr.put('false;'#10) else wr.put('true;'#10);
1179 exit;
1180 end;
1181 TType.TChar:
1182 begin
1183 if (mMaxDim = 0) then raise Exception.Create(Format('invalid string size definition for field ''%s''', [mName]));
1184 wr.put(quoteStr(mSVal));
1185 wr.put(';'#10);
1186 exit;
1187 end;
1188 TType.TByte,
1189 TType.TUByte,
1190 TType.TShort,
1191 TType.TUShort,
1192 TType.TInt,
1193 TType.TUInt:
1194 begin
1195 wr.put('%d;'#10, [mIVal]);
1196 exit;
1197 end;
1198 TType.TString:
1199 begin
1200 wr.put(quoteStr(mSVal));
1201 wr.put(';'#10);
1202 exit;
1203 end;
1204 TType.TPoint,
1205 TType.TSize:
1206 begin
1207 wr.put('(%d %d);'#10, [mIVal, mIVal2]);
1208 exit;
1209 end;
1210 TType.TList:
1211 begin
1212 assert(false);
1213 exit;
1214 end;
1215 TType.TTrigData:
1216 begin
1217 assert(false);
1218 exit;
1219 end;
1220 else raise Exception.Create('ketmar forgot to handle some field type');
1221 end;
1222 raise Exception.Create(Format('cannot parse field ''%s'' yet', [mName]));
1223 end;
1226 procedure TDynField.parseBinValue (st: TStream);
1227 var
1228 rec, rc: TDynRecord;
1229 tfld: TDynField;
1230 es: TDynEBS = nil;
1231 tdata: PByte = nil;
1232 f, mask: Integer;
1233 s: AnsiString;
1234 begin
1235 case mEBS of
1236 TEBS.TNone: begin end;
1237 TEBS.TRec:
1238 begin
1239 // this must be triggerdata
1240 if (mType = TType.TTrigData) then
1241 begin
1242 assert(mMaxDim > 0);
1243 rec := mOwner;
1244 // find trigger definition
1245 tfld := rec.trigTypeField();
1246 if (tfld = nil) then raise Exception.Create(Format('triggerdata value for field ''%s'' in record ''%s'' without TriggerType field', [mName, rec.mName]));
1247 rc := mOwner.mOwner.findTrigFor(tfld.mSVal); // find in mapdef
1248 if (rc = nil) then raise Exception.Create(Format('triggerdata definition for field ''%s'' in record ''%s'' with type ''%s'' not found', [mName, rec.mName, tfld.mSVal]));
1249 rc := rc.clone();
1250 rc.mHeaderRec := mOwner.mHeaderRec;
1251 try
1252 rc.parseBinValue(st, true);
1253 mRecRef := rc;
1254 rc := nil;
1255 finally
1256 rc.Free();
1257 end;
1258 mDefined := true;
1259 exit;
1260 end
1261 else
1262 begin
1263 // not a trigger data
1264 case mType of
1265 TType.TByte: f := readShortInt(st);
1266 TType.TUByte: f := readByte(st);
1267 TType.TShort: f := readSmallInt(st);
1268 TType.TUShort: f := readWord(st);
1269 TType.TInt: f := readLongInt(st);
1270 TType.TUInt: f := readLongWord(st);
1271 else raise Exception.Create(Format('invalid non-numeric type ''%s'' for field ''%s'' of record ''%s''', [getTypeName(mType), mName, mEBSTypeName]));
1272 end;
1273 if mAsMonsterId then Dec(f);
1274 if (f < 0) then mRecRefId := '' else mRecRefId := Format('%s%d', [mEBSTypeName, f]);
1275 end;
1276 mDefined := true;
1277 exit;
1278 end;
1279 TEBS.TEnum,
1280 TEBS.TBitSet:
1281 begin
1282 assert(mMaxDim < 0);
1283 case mType of
1284 TType.TByte: f := readShortInt(st);
1285 TType.TUByte: f := readByte(st);
1286 TType.TShort: f := readSmallInt(st);
1287 TType.TUShort: f := readWord(st);
1288 TType.TInt: f := readLongInt(st);
1289 TType.TUInt: f := readLongWord(st);
1290 else raise Exception.Create(Format('invalid non-numeric type ''%s'' for field ''%s'' of record ''%s''', [getTypeName(mType), mName, mEBSTypeName]));
1291 end;
1292 es := nil;
1293 if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS);
1294 if (es = nil) or (es.mIsEnum <> (mEBS = TEBS.TEnum)) then raise Exception.Create(Format('record enum type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]));
1295 mIVal := f;
1296 // build enum/bitfield values
1297 if (mEBS = TEBS.TEnum) then
1298 begin
1299 mSVal := es.nameByValue(mIVal);
1300 if (Length(mSVal) = 0) then raise Exception.Create(Format('record enum type ''%s'' for field ''%s'' has invalid value %d', [mEBSTypeName, mName, mIVal]));
1301 end
1302 else
1303 begin
1304 // special for 'none'
1305 if (mIVal = 0) then
1306 begin
1307 mSVal := es.nameByValue(mIVal);
1308 if (Length(mSVal) = 0) then raise Exception.Create(Format('record bitset type ''%s'' for field ''%s'' has invalid value %d', [mEBSTypeName, mName, mIVal]));
1309 end
1310 else
1311 begin
1312 mSVal := '';
1313 mask := 1;
1314 while (mask <> 0) do
1315 begin
1316 if ((mIVal and mask) <> 0) then
1317 begin
1318 s := es.nameByValue(mask);
1319 if (Length(s) = 0) then raise Exception.Create(Format('record bitset type ''%s'' for field ''%s'' has invalid value %d', [mEBSTypeName, mName, mask]));
1320 if (Length(mSVal) <> 0) then mSVal += '+';
1321 mSVal += s;
1322 end;
1323 mask := mask shl 1;
1324 end;
1325 end;
1326 end;
1327 //writeln('ebs <', es.mName, '>: ', mSVal);
1328 mDefined := true;
1329 exit;
1330 end;
1331 else raise Exception.Create('ketmar forgot to handle some EBS type');
1332 end;
1334 case mType of
1335 TType.TBool:
1336 begin
1337 f := readByte(st);
1338 if (f <> 0) then f := 1;
1339 if mNegBool then f := 1-f;
1340 mIVal := f;
1341 mDefined := true;
1342 exit;
1343 end;
1344 TType.TChar:
1345 begin
1346 if (mMaxDim < 0) then
1347 begin
1348 mIVal := readByte(st);
1349 end
1350 else
1351 begin
1352 mSVal := '';
1353 GetMem(tdata, mMaxDim);
1354 try
1355 st.ReadBuffer(tdata^, mMaxDim);
1356 f := 0;
1357 while (f < mMaxDim) and (tdata[f] <> 0) do Inc(f);
1358 if (f > 0) then
1359 begin
1360 SetLength(mSVal, f);
1361 Move(tdata^, PChar(mSVal)^, f);
1362 mSVal := win2utf(mSVal);
1363 end;
1364 finally
1365 FreeMem(tdata);
1366 end;
1367 end;
1368 mDefined := true;
1369 exit;
1370 end;
1371 TType.TByte: begin mIVal := readShortInt(st); mDefined := true; exit; end;
1372 TType.TUByte: begin mIVal := readByte(st); mDefined := true; exit; end;
1373 TType.TShort: begin mIVal := readSmallInt(st); mDefined := true; exit; end;
1374 TType.TUShort: begin mIVal := readWord(st); mDefined := true; exit; end;
1375 TType.TInt: begin mIVal := readLongInt(st); mDefined := true; exit; end;
1376 TType.TUInt: begin mIVal := readLongWord(st); mDefined := true; exit; end;
1377 TType.TString:
1378 begin
1379 raise Exception.Create('cannot read strings from binaries yet');
1380 exit;
1381 end;
1382 TType.TPoint:
1383 begin
1384 mIVal := readLongInt(st);
1385 mIVal2 := readLongInt(st);
1386 mDefined := true;
1387 exit;
1388 end;
1389 TType.TSize:
1390 begin
1391 mIVal := readWord(st);
1392 mIVal2 := readWord(st);
1393 mDefined := true;
1394 exit;
1395 end;
1396 TType.TList:
1397 begin
1398 assert(false);
1399 exit;
1400 end;
1401 TType.TTrigData:
1402 begin
1403 assert(false);
1404 exit;
1405 end;
1406 else raise Exception.Create('ketmar forgot to handle some field type');
1407 end;
1408 raise Exception.Create(Format('cannot parse field ''%s'' yet', [mName]));
1409 end;
1412 procedure TDynField.parseValue (pr: TTextParser);
1414 procedure parseInt (min, max: Integer);
1415 begin
1416 mIVal := pr.expectInt();
1417 if (mIVal < min) or (mIVal > max) then raise Exception.Create(Format('invalid %s value for field ''%s''', [getTypeName(mType), mName]));
1418 mDefined := true;
1419 end;
1421 var
1422 rec, rc: TDynRecord;
1423 es: TDynEBS = nil;
1424 tfld: TDynField;
1425 tk: AnsiString;
1426 edim: AnsiChar;
1427 begin
1428 // if this field should contain struct, convert type and parse struct
1429 case mEBS of
1430 TEBS.TNone: begin end;
1431 TEBS.TRec:
1432 begin
1433 // ugly hack. sorry.
1434 if (mType = TType.TTrigData) then
1435 begin
1436 pr.expectTT(pr.TTBegin);
1437 if (pr.tokType = pr.TTEnd) then
1438 begin
1439 // '{}'
1440 mRecRef := nil;
1441 pr.expectTT(pr.TTEnd);
1442 end
1443 else
1444 begin
1445 rec := mOwner;
1446 // find trigger definition
1447 tfld := rec.trigTypeField();
1448 if (tfld = nil) then raise Exception.Create(Format('triggerdata value for field ''%s'' in record ''%s'' without ''type'' field', [mName, rec.mName]));
1449 rc := mOwner.mOwner.findTrigFor(tfld.mSVal); // find in mapdef
1450 if (rc = nil) then raise Exception.Create(Format('triggerdata definition for field ''%s'' in record ''%s'' with type ''%s'' not found', [mName, rec.mName, tfld.mSVal]));
1451 rc := rc.clone();
1452 rc.mHeaderRec := mOwner.mHeaderRec;
1453 //writeln(rc.definition);
1454 try
1455 rc.parseValue(pr, true);
1456 mRecRef := rc;
1457 rc := nil;
1458 finally
1459 rc.Free();
1460 end;
1461 end;
1462 mDefined := true;
1463 pr.eatTT(pr.TTSemi); // hack: allow (but don't require) semicolon after inline records
1464 exit;
1465 end;
1466 // other record types
1467 if (pr.tokType = pr.TTId) then
1468 begin
1469 if pr.eatId('null') then
1470 begin
1471 mRecRef := nil;
1472 end
1473 else
1474 begin
1475 rec := mOwner.findRecordByTypeId(mEBSTypeName, pr.tokStr);
1476 if (rec = nil) then raise Exception.Create(Format('record ''%s'' (%s) value for field ''%s'' not found', [pr.tokStr, mEBSTypeName, mName]));
1477 pr.expectId();
1478 mRecRef := rec;
1479 end;
1480 mDefined := true;
1481 pr.expectTT(pr.TTSemi);
1482 exit;
1483 end
1484 else if (pr.tokType = pr.TTBegin) then
1485 begin
1486 //rec := mOwner.mOwner.findRecType(mEBSTypeName); // find in mapdef
1487 rec := nil;
1488 if (mEBSType <> nil) and (mEBSType is TDynRecord) then rec := (mEBSType as TDynRecord);
1489 if (rec = nil) then raise Exception.Create(Format('record type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]));
1490 rc := rec.clone();
1491 rc.mHeaderRec := mOwner.mHeaderRec;
1492 rc.parseValue(pr);
1493 mRecRef := rc;
1494 mDefined := true;
1495 if mOwner.addRecordByType(mEBSTypeName, rc) then
1496 begin
1497 //raise Exception.Create(Format('record type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]));
1498 e_LogWritefln('duplicate record with id ''%s'' for field ''%s'' in record ''%s''', [rc.mId, mName, mOwner.mName]);
1499 end;
1500 pr.eatTT(pr.TTSemi); // hack: allow (but don't require) semicolon after inline records
1501 exit;
1502 end;
1503 pr.expectTT(pr.TTBegin);
1504 end;
1505 TEBS.TEnum:
1506 begin
1507 //es := mOwner.mOwner.findEBSType(mEBSTypeName); // find in mapdef
1508 es := nil;
1509 if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS);
1510 if (es = nil) or (not es.mIsEnum) then raise Exception.Create(Format('record enum type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]));
1511 tk := pr.expectId();
1512 if not es.has[tk] then raise Exception.Create(Format('record enum value ''%s'' of type ''%s'' for field ''%s'' not found', [tk, mEBSTypeName, mName]));
1513 mIVal := es.field[tk];
1514 mSVal := tk;
1515 //writeln('ENUM ', mEBSName, '; element <', mSVal, '> with value ', mIVal);
1516 mDefined := true;
1517 pr.expectTT(pr.TTSemi);
1518 exit;
1519 end;
1520 TEBS.TBitSet:
1521 begin
1522 //es := mOwner.mOwner.findEBSType(mEBSTypeName); // find in mapdef
1523 es := nil;
1524 if (mEBSType <> nil) and (mEBSType is TDynEBS) then es := (mEBSType as TDynEBS);
1525 if (es = nil) or es.mIsEnum then raise Exception.Create(Format('record bitset type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]));
1526 mIVal := 0;
1527 while true do
1528 begin
1529 tk := pr.expectId();
1530 if not es.has[tk] then raise Exception.Create(Format('record bitset value ''%s'' of type ''%s'' for field ''%s'' not found', [tk, mEBSTypeName, mName]));
1531 mIVal := mIVal or es.field[tk];
1532 mSVal := tk;
1533 if (pr.tokType <> pr.TTDelim) or ((pr.tokChar <> '|') and (pr.tokChar <> '+')) then break;
1534 if mBitSetUnique then raise Exception.Create(Format('record bitset of type ''%s'' for field ''%s'' expects only one value', [tk, mEBSTypeName, mName]));
1535 //pr.expectDelim('|');
1536 pr.skipToken(); // plus or pipe
1537 end;
1538 mDefined := true;
1539 pr.expectTT(pr.TTSemi);
1540 exit;
1541 end;
1542 else raise Exception.Create('ketmar forgot to handle some EBS type');
1543 end;
1545 case mType of
1546 TType.TBool:
1547 begin
1548 if pr.eatId('true') or pr.eatId('tan') or pr.eatId('yes') then mIVal := 1
1549 else if pr.eatId('false') or pr.eatId('ona') or pr.eatId('no') then mIVal := 0
1550 else raise Exception.Create(Format('invalid bool value for field ''%s''', [mName]));
1551 mDefined := true;
1552 pr.expectTT(pr.TTSemi);
1553 exit;
1554 end;
1555 TType.TChar:
1556 begin
1557 if (mMaxDim = 0) then raise Exception.Create(Format('invalid string size definition for field ''%s''', [mName]));
1558 mSVal := pr.expectStr(true);
1559 if (mMaxDim < 0) then
1560 begin
1561 // single char
1562 if (Length(mSVal) <> 1) then raise Exception.Create(Format('invalid string size for field ''%s''', [mName]));
1563 mIVal := Integer(mSVal[1]);
1564 mSVal := '';
1565 end
1566 else
1567 begin
1568 // string
1569 if (Length(mSVal) > mMaxDim) then raise Exception.Create(Format('invalid string size for field ''%s''', [mName]));
1570 end;
1571 mDefined := true;
1572 pr.expectTT(pr.TTSemi);
1573 exit;
1574 end;
1575 TType.TByte:
1576 begin
1577 parseInt(-128, 127);
1578 pr.expectTT(pr.TTSemi);
1579 exit;
1580 end;
1581 TType.TUByte:
1582 begin
1583 parseInt(0, 255);
1584 pr.expectTT(pr.TTSemi);
1585 exit;
1586 end;
1587 TType.TShort:
1588 begin
1589 parseInt(-32768, 32768);
1590 pr.expectTT(pr.TTSemi);
1591 exit;
1592 end;
1593 TType.TUShort:
1594 begin
1595 parseInt(0, 65535);
1596 pr.expectTT(pr.TTSemi);
1597 exit;
1598 end;
1599 TType.TInt:
1600 begin
1601 parseInt(Integer($80000000), $7fffffff);
1602 pr.expectTT(pr.TTSemi);
1603 exit;
1604 end;
1605 TType.TUInt:
1606 begin
1607 parseInt(0, $7fffffff); //FIXME
1608 pr.expectTT(pr.TTSemi);
1609 exit;
1610 end;
1611 TType.TString:
1612 begin
1613 mSVal := pr.expectStr(true);
1614 mDefined := true;
1615 pr.expectTT(pr.TTSemi);
1616 exit;
1617 end;
1618 TType.TPoint,
1619 TType.TSize:
1620 begin
1621 if pr.eatDelim('[') then edim := ']' else begin pr.expectDelim('('); edim := ')'; end;
1622 mIVal := pr.expectInt();
1623 if (mType = TType.TSize) then
1624 begin
1625 if (mIVal < 0) or (mIVal > 32767) then raise Exception.Create(Format('invalid %s value for field ''%s''', [getTypeName(mType), mName]));
1626 end;
1627 mIVal2 := pr.expectInt();
1628 if (mType = TType.TSize) then
1629 begin
1630 if (mIVal2 < 0) or (mIVal2 > 32767) then raise Exception.Create(Format('invalid %s value for field ''%s''', [getTypeName(mType), mName]));
1631 end;
1632 mDefined := true;
1633 pr.expectDelim(edim);
1634 pr.expectTT(pr.TTSemi);
1635 exit;
1636 end;
1637 TType.TList:
1638 begin
1639 assert(false);
1640 exit;
1641 end;
1642 TType.TTrigData:
1643 begin
1644 assert(false);
1645 exit;
1646 end;
1647 else raise Exception.Create('ketmar forgot to handle some field type');
1648 end;
1649 raise Exception.Create(Format('cannot parse field ''%s'' yet', [mName]));
1650 end;
1653 // ////////////////////////////////////////////////////////////////////////// //
1654 constructor TDynRecord.Create (pr: TTextParser);
1655 begin
1656 if (pr = nil) then raise Exception.Create('cannot create record type without type definition');
1657 mId := '';
1658 mName := '';
1659 mSize := 0;
1660 mFields := TDynFieldList.Create();
1661 {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
1662 mFieldsHash := hashNewStrInt();
1663 {$ENDIF}
1664 mTrigTypes := nil;
1665 mHeader := false;
1666 mHeaderRec := nil;
1667 mBinBlock := -1;
1668 mTagInt := 0;
1669 mTagPtr := nil;
1670 parseDef(pr);
1671 end;
1674 constructor TDynRecord.Create ();
1675 begin
1676 mName := '';
1677 mSize := 0;
1678 mFields := TDynFieldList.Create();
1679 {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
1680 mFieldsHash := hashNewStrInt();
1681 {$ENDIF}
1682 mTrigTypes := nil;
1683 mHeader := false;
1684 mHeaderRec := nil;
1685 mTagInt := 0;
1686 mTagPtr := nil;
1687 end;
1690 destructor TDynRecord.Destroy ();
1691 begin
1692 mName := '';
1693 mFields.Free();
1694 mFields := nil;
1695 {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
1696 mFieldsHash.Free();
1697 mFieldsHash := nil;
1698 {$ENDIF}
1699 mTrigTypes := nil;
1700 mHeaderRec := nil;
1701 mTagInt := 0;
1702 mTagPtr := nil;
1703 inherited;
1704 end;
1707 procedure TDynRecord.addField (fld: TDynField); inline;
1708 begin
1709 if (fld = nil) then raise Exception.Create('cannot append nil field to record');
1710 mFields.append(fld);
1711 {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
1712 if (Length(fld.mName) > 0) then mFieldsHash.put(fld.mName, mFields.count-1);
1713 {$ENDIF}
1714 end;
1717 function TDynRecord.addFieldChecked (fld: TDynField): Boolean; inline; // `true`: duplicate name
1718 begin
1719 result := false;
1720 if (fld = nil) then raise Exception.Create('cannot append nil field to record');
1721 {$IF not DEFINED(XDYNREC_USE_FIELDHASH)}
1722 if (Length(fld.mName) > 0) then result := hasByName(fld.mName);
1723 {$ENDIF}
1724 mFields.append(fld);
1725 {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
1726 if (Length(fld.mName) > 0) then result := mFieldsHash.put(fld.mName, mFields.count-1);
1727 {$ENDIF}
1728 end;
1731 function TDynRecord.findByName (const aname: AnsiString): Integer; inline;
1732 begin
1733 {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
1734 if not mFieldsHash.get(aname, result) then result := -1;
1735 {$ELSE}
1736 result := 0;
1737 while (result < mFields.count) do
1738 begin
1739 if StrEqu(aname, mFields[result].mName) then exit;
1740 Inc(result);
1741 end;
1742 result := -1;
1743 {$ENDIF}
1744 end;
1747 function TDynRecord.hasByName (const aname: AnsiString): Boolean; inline;
1748 begin
1749 result := (findByName(aname) >= 0);
1750 end;
1753 function TDynRecord.getFieldByName (const aname: AnsiString): TDynField; inline;
1754 var
1755 f: Integer;
1756 begin
1757 f := findByName(aname);
1758 if (f >= 0) then result := mFields[f] else result := nil;
1759 end;
1762 function TDynRecord.getFieldAt (idx: Integer): TDynField; inline;
1763 begin
1764 if (idx >= 0) and (idx < mFields.count) then result := mFields[idx] else result := nil;
1765 end;
1768 function TDynRecord.getCount (): Integer; inline;
1769 begin
1770 result := mFields.count;
1771 end;
1774 function TDynRecord.getIsTrigData (): Boolean; inline;
1775 begin
1776 result := (Length(mTrigTypes) > 0);
1777 end;
1780 function TDynRecord.getIsForTrig (const aname: AnsiString): Boolean; inline;
1781 var
1782 f: Integer;
1783 begin
1784 result := true;
1785 for f := 0 to High(mTrigTypes) do if StrEqu(mTrigTypes[f], aname) then exit;
1786 result := false;
1787 end;
1790 function TDynRecord.getForTrigCount (): Integer; inline;
1791 begin
1792 result := Length(mTrigTypes);
1793 end;
1796 function TDynRecord.getForTrigAt (idx: Integer): AnsiString; inline;
1797 begin
1798 if (idx >= 0) and (idx < Length(mTrigTypes)) then result := mTrigTypes[idx] else result := '';
1799 end;
1802 function TDynRecord.clone (): TDynRecord;
1803 var
1804 fld: TDynField;
1805 f: Integer;
1806 begin
1807 result := TDynRecord.Create();
1808 result.mOwner := mOwner;
1809 result.mId := mId;
1810 result.mPasName := mPasName;
1811 result.mName := mName;
1812 result.mSize := mSize;
1813 if (mFields.count > 0) then
1814 begin
1815 result.mFields.capacity := mFields.count;
1816 for fld in mFields do result.addField(fld.clone(result));
1817 end;
1818 SetLength(result.mTrigTypes, Length(mTrigTypes));
1819 for f := 0 to High(mTrigTypes) do result.mTrigTypes[f] := mTrigTypes[f];
1820 result.mHeader := mHeader;
1821 result.mBinBlock := mBinBlock;
1822 result.mHeaderRec := mHeaderRec;
1823 result.mTagInt := mTagInt;
1824 result.mTagPtr := mTagPtr;
1825 end;
1828 function TDynRecord.findRecordByTypeId (const atypename, aid: AnsiString): TDynRecord;
1829 var
1830 fld: TDynField;
1831 idx: Integer;
1832 begin
1833 result := nil;
1834 if (Length(aid) = 0) then exit;
1835 // find record data
1836 fld := mHeaderRec.field[atypename];
1837 if (fld = nil) then exit;
1838 if (fld.mType <> fld.TType.TList) then raise Exception.Create(Format('cannot get record of type ''%s'' due to name conflict with ordinary field', [atypename]));
1839 // find by id
1840 if (fld.mRVal <> nil) then
1841 begin
1842 if fld.mRHash.get(aid, idx) then begin result := fld.mRVal[idx]; exit; end;
1843 end;
1844 // alas
1845 end;
1848 function TDynRecord.findRecordNumByType (const atypename: AnsiString; rc: TDynRecord): Integer;
1849 var
1850 fld: TDynField;
1851 idx: Integer;
1852 begin
1853 result := -1;
1854 // find record data
1855 fld := mHeaderRec.field[atypename];
1856 if (fld = nil) then exit;
1857 if (fld.mType <> fld.TType.TList) then raise Exception.Create(Format('cannot get record of type ''%s'' due to name conflict with ordinary field', [atypename]));
1858 // find by ref
1859 if (fld.mRVal <> nil) then
1860 begin
1861 for idx := 0 to fld.mRVal.count-1 do
1862 begin
1863 if (fld.mRVal[idx] = rc) then begin result := idx; exit; end;
1864 end;
1865 end;
1866 // alas
1867 end;
1870 function TDynRecord.addRecordByType (const atypename: AnsiString; rc: TDynRecord): Boolean;
1871 var
1872 fld: TDynField;
1873 begin
1874 // find record data
1875 fld := mHeaderRec.field[atypename];
1876 if (fld = nil) then
1877 begin
1878 // first record
1879 fld := TDynField.Create(atypename, TDynField.TType.TList);
1880 fld.mOwner := mHeaderRec;
1881 mHeaderRec.addField(fld);
1882 end;
1883 if (fld.mType <> fld.TType.TList) then raise Exception.Create(Format('cannot append record of type ''%s'' due to name conflict with ordinary field', [atypename]));
1884 // append
1885 if (fld.mRVal = nil) then
1886 begin
1887 fld.mRVal := TDynRecList.Create();
1888 fld.mRHash := hashNewStrInt();
1889 end;
1890 result := fld.addListItem(rc);
1891 end;
1894 function TDynRecord.isSimpleEqu (rec: TDynRecord): Boolean;
1895 var
1896 f: Integer;
1897 begin
1898 if (rec = nil) then begin result := false; exit; end; // self.mRecRef can't be `nil` here
1899 if (rec = self) then begin result := true; exit; end;
1900 if (mFields.count <> rec.mFields.count) then begin result := false; exit; end;
1901 result := false;
1902 for f := 0 to mFields.count-1 do
1903 begin
1904 if not mFields[f].isSimpleEqu(rec.mFields[f]) then exit;
1905 end;
1906 result := true;
1907 end;
1910 function TDynRecord.trigTypeField (): TDynField;
1911 var
1912 fld: TDynField;
1913 es: TDynEBS = nil;
1914 begin
1915 for fld in mFields do
1916 begin
1917 if (fld.mEBS <> TDynField.TEBS.TEnum) then continue;
1918 if not (fld.mEBSType is TDynEBS) then continue;
1919 es := (fld.mEBSType as TDynEBS);
1920 assert(es <> nil);
1921 if StrEqu(es.mName, 'TriggerType') then begin result := fld; exit; end;
1922 end;
1923 result := nil;
1924 end;
1927 // number of records of the given instance
1928 function TDynRecord.instanceCount (const typename: AnsiString): Integer;
1929 var
1930 fld: TDynField;
1931 begin
1932 result := 0;
1933 fld := field[typename];
1934 if (fld <> nil) and (fld.mType = fld.TType.TList) then result := fld.mRVal.count;
1935 end;
1938 procedure TDynRecord.setUserField (const fldname: AnsiString; v: LongInt);
1939 var
1940 fld: TDynField;
1941 begin
1942 if (Length(fldname) = 0) then exit;
1943 fld := field[fldname];
1944 if (fld <> nil) then
1945 begin
1946 if (fld.mType <> fld.TType.TInt) or (fld.mEBS <> fld.TEBS.TNone) then
1947 begin
1948 raise Exception.Create(Format('invalid user field ''%s'' type', [fld.name]));
1949 end;
1950 end
1951 else
1952 begin
1953 fld := TDynField.Create(fldname, fld.TType.TInt);
1954 fld.mOwner := self;
1955 fld.mIVal := v;
1956 fld.mInternal := true;
1957 fld.mDefined := true;
1958 addField(fld);
1959 end;
1960 end;
1963 procedure TDynRecord.setUserField (const fldname: AnsiString; v: AnsiString);
1964 var
1965 fld: TDynField;
1966 begin
1967 if (Length(fldname) = 0) then exit;
1968 fld := field[fldname];
1969 if (fld <> nil) then
1970 begin
1971 if (fld.mType <> fld.TType.TString) or (fld.mEBS <> fld.TEBS.TNone) then
1972 begin
1973 raise Exception.Create(Format('invalid user field ''%s'' type', [fld.name]));
1974 end;
1975 end
1976 else
1977 begin
1978 fld := TDynField.Create(fldname, fld.TType.TString);
1979 fld.mOwner := self;
1980 fld.mSVal := v;
1981 fld.mInternal := true;
1982 fld.mDefined := true;
1983 addField(fld);
1984 end;
1985 end;
1988 procedure TDynRecord.parseDef (pr: TTextParser);
1989 var
1990 fld: TDynField;
1991 tdn: AnsiString;
1992 begin
1993 if pr.eatId('TriggerData') then
1994 begin
1995 pr.expectId('for');
1996 if pr.eatDelim('(') then
1997 begin
1998 while true do
1999 begin
2000 while pr.eatTT(pr.TTComma) do begin end;
2001 if pr.eatDelim(')') then break;
2002 tdn := pr.expectId();
2003 if isForTrig[tdn] then raise Exception.Create(Format('duplicate trigdata ''%s'' trigtype ''%s''', [mName, tdn]));
2004 SetLength(mTrigTypes, Length(mTrigTypes)+1);
2005 mTrigTypes[High(mTrigTypes)] := tdn;
2006 end;
2007 end
2008 else
2009 begin
2010 tdn := pr.expectId();
2011 SetLength(mTrigTypes, 1);
2012 mTrigTypes[0] := tdn;
2013 end;
2014 mName := 'TriggerData';
2015 end
2016 else
2017 begin
2018 mPasName := pr.expectId(); // pascal record name
2019 pr.expectId('is');
2020 mName := pr.expectStr();
2021 while (pr.tokType <> pr.TTBegin) do
2022 begin
2023 if pr.eatId('header') then begin mHeader := true; continue; end;
2024 if pr.eatId('size') then
2025 begin
2026 if (mSize > 0) then raise Exception.Create(Format('duplicate `size` in record ''%s''', [mName]));
2027 mSize := pr.expectInt();
2028 if (mSize < 1) then raise Exception.Create(Format('invalid record ''%s'' size: %d', [mName, mSize]));
2029 pr.expectId('bytes');
2030 continue;
2031 end;
2032 if pr.eatId('binblock') then
2033 begin
2034 if (mBinBlock >= 0) then raise Exception.Create(Format('duplicate `binblock` in record ''%s''', [mName]));
2035 mBinBlock := pr.expectInt();
2036 if (mBinBlock < 1) then raise Exception.Create(Format('invalid record ''%s'' binblock: %d', [mName, mBinBlock]));
2037 continue;
2038 end;
2039 end;
2040 end;
2042 pr.expectTT(pr.TTBegin);
2043 // load fields
2044 while (pr.tokType <> pr.TTEnd) do
2045 begin
2046 fld := TDynField.Create(pr);
2047 //if hasByName(fld.name) then begin fld.Free(); raise Exception.Create(Format('duplicate field ''%s''', [fld.name])); end;
2048 // append
2049 fld.mOwner := self;
2050 if addFieldChecked(fld) then
2051 begin
2052 fld.Free();
2053 raise Exception.Create(Format('duplicate field ''%s''', [fld.name]));
2054 end;
2055 // done with field
2056 end;
2057 pr.expectTT(pr.TTEnd);
2058 end;
2061 function TDynRecord.pasdef (): AnsiString;
2062 var
2063 fld: TDynField;
2064 begin
2065 if isTrigData then
2066 begin
2067 assert(false);
2068 result := '';
2069 end
2070 else
2071 begin
2072 // record
2073 result := ' '+mPasName+' = packed record'#10;
2074 end;
2075 for fld in mFields do
2076 begin
2077 if fld.mInternal then continue;
2078 if (fld.mBinOfs < 0) then continue;
2079 result += ' '+fld.pasdef+#10;
2080 end;
2081 result += ' end;'#10;
2082 end;
2085 function TDynRecord.definition (): AnsiString;
2086 var
2087 f: Integer;
2088 begin
2089 if isTrigData then
2090 begin
2091 // trigger data
2092 result := 'TriggerData for ';
2093 if (Length(mTrigTypes) > 1) then
2094 begin
2095 result += '(';
2096 for f := 0 to High(mTrigTypes) do
2097 begin
2098 if (f <> 0) then result += ', ';
2099 result += mTrigTypes[f];
2100 end;
2101 result += ')';
2102 end
2103 else
2104 begin
2105 result += mTrigTypes[0];
2106 end;
2107 end
2108 else
2109 begin
2110 // record
2111 result := mPasName+' is '+quoteStr(mName);
2112 if (mSize >= 0) then result += Format(' size %d bytes', [mSize]);
2113 if mHeader then result += ' header';
2114 end;
2115 result += ' {'#10;
2116 for f := 0 to mFields.count-1 do
2117 begin
2118 result += ' ';
2119 result += mFields[f].definition;
2120 result += ';'#10;
2121 end;
2122 result += '}';
2123 end;
2126 procedure TDynRecord.parseBinValue (st: TStream; forceData: Boolean=false);
2127 var
2128 sign: string[4];
2129 btype: Integer;
2130 bsize: Integer;
2131 buf: PByte = nil;
2132 loaded: array[0..255] of Boolean;
2133 rec, rect: TDynRecord;
2134 fld: TDynField;
2135 f: Integer;
2136 mst: TSFSMemoryChunkStream = nil;
2138 procedure linkNames (rec: TDynRecord);
2139 var
2140 fld: TDynField;
2141 rt: TDynRecord;
2142 begin
2143 //writeln('*** rec: ', rec.mName, '.', rec.mId, ' (', rec.mFields.count, ')');
2144 for fld in rec.mFields do
2145 begin
2146 if (fld.mType = TDynField.TType.TTrigData) then
2147 begin
2148 if (fld.mRecRef <> nil) then linkNames(fld.mRecRef);
2149 continue;
2150 end;
2151 if (Length(fld.mRecRefId) = 0) then continue;
2152 assert(fld.mEBSType <> nil);
2153 rt := findRecordByTypeId(fld.mEBSTypeName, fld.mRecRefId);
2154 if (rt = nil) then
2155 begin
2156 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);
2157 //raise Exception.Create(Format('record of type ''%s'' with id ''%s'' links to inexistant record of type ''%s'' with id ''%s''', [rec.mName, rec.mId, fld.mEBSTypeName, fld.mRecRefId]));
2158 end;
2159 //writeln(' ', rec.mName, '.', rec.mId, ':', fld.mName, ' -> ', rt.mName, '.', rt.mId, ' (', fld.mEBSTypeName, '.', fld.mRecRefId, ')');
2160 fld.mRecRefId := '';
2161 fld.mRecRef := rt;
2162 fld.mDefined := true;
2163 end;
2164 for fld in rec.mFields do
2165 begin
2166 //writeln(' ', fld.mName);
2167 fld.fixDefaultValue(); // just in case
2168 end;
2169 end;
2171 begin
2172 for f := 0 to High(loaded) do loaded[f] := false;
2173 mst := TSFSMemoryChunkStream.Create(nil, 0);
2174 try
2175 if mHeader and not forceData then
2176 begin
2177 // parse map file as sequence of blocks
2178 sign[0] := #4;
2179 st.ReadBuffer(sign[1], 4);
2180 if (sign <> 'MAP'#1) then raise Exception.Create('invalid binary map signature');
2181 // parse blocks
2182 while (st.position < st.size) do
2183 begin
2184 btype := readByte(st);
2185 if (btype = 0) then break; // no more blocks
2186 readLongWord(st); // reserved
2187 bsize := readLongInt(st);
2188 {$IF DEFINED(D2D_XDYN_DEBUG)}writeln('btype=', btype, '; bsize=', bsize);{$ENDIF}
2189 if (bsize < 0) or (bsize > $1fffffff) then raise Exception.Create(Format('block of type %d has invalid size %d', [btype, bsize]));
2190 if loaded[btype] then raise Exception.Create(Format('block of type %d already loaded', [btype]));
2191 loaded[btype] := true;
2192 // find record type for this block
2193 rect := nil;
2194 for rec in mOwner.recTypes do if (rec.mBinBlock = btype) then begin rect := rec; break; end;
2195 if (rect = nil) then raise Exception.Create(Format('block of type %d has no corresponding record', [btype]));
2196 //writeln('found type ''', rec.mName, ''' for block type ', btype);
2197 if (rec.mSize = 0) or ((bsize mod rec.mSize) <> 0) then raise Exception.Create(Format('block of type %d has invalid number of records', [btype]));
2198 // header?
2199 if (rect.mHeader) then
2200 begin
2201 if (bsize <> mSize) then raise Exception.Create(Format('header block of type %d has invalid number of records', [btype]));
2202 GetMem(buf, bsize);
2203 st.ReadBuffer(buf^, bsize);
2204 mst.setup(buf, mSize);
2205 parseBinValue(mst, true); // force parsing data
2206 end
2207 else
2208 begin
2209 // create list for this type
2210 fld := TDynField.Create(rec.mName, TDynField.TType.TList);
2211 fld.mOwner := self;
2212 addField(fld);
2213 if (bsize > 0) then
2214 begin
2215 GetMem(buf, bsize);
2216 st.ReadBuffer(buf^, bsize);
2217 for f := 0 to (bsize div rec.mSize)-1 do
2218 begin
2219 mst.setup(buf+f*rec.mSize, rec.mSize);
2220 rec := rect.clone();
2221 rec.mHeaderRec := self;
2222 rec.parseBinValue(mst);
2223 rec.mId := Format('%s%d', [rec.mName, f]);
2224 fld.addListItem(rec);
2225 //writeln('parsed ''', rec.mId, '''...');
2226 end;
2227 end;
2228 end;
2229 FreeMem(buf);
2230 buf := nil;
2231 //st.position := st.position+bsize;
2232 end;
2233 // link fields
2234 for fld in mFields do
2235 begin
2236 if (fld.mType <> TDynField.TType.TList) then continue;
2237 for rec in fld.mRVal do linkNames(rec);
2238 end;
2239 exit;
2240 end;
2242 // read fields
2243 if StrEqu(mName, 'TriggerData') then mSize := Integer(st.size-st.position);
2244 if (mSize < 1) then raise Exception.Create(Format('cannot read record of type ''%s'' with unknown size', [mName]));
2245 GetMem(buf, mSize);
2246 st.ReadBuffer(buf^, mSize);
2247 for fld in mFields do
2248 begin
2249 if fld.mInternal then continue;
2250 if (fld.mBinOfs < 0) then continue;
2251 if (fld.mBinOfs >= st.size) then raise Exception.Create(Format('record of type ''%s'' has invalid field ''%s''', [fld.mName]));
2252 mst.setup(buf+fld.mBinOfs, mSize-fld.mBinOfs);
2253 //writeln('parsing ''', mName, '.', fld.mName, '''...');
2254 fld.parseBinValue(mst);
2255 end;
2256 finally
2257 mst.Free();
2258 if (buf <> nil) then FreeMem(buf);
2259 end;
2260 end;
2263 procedure TDynRecord.writeBinTo (st: TStream; trigbufsz: Integer=-1; onlyFields: Boolean=false);
2264 var
2265 fld: TDynField;
2266 rec, rv: TDynRecord;
2267 buf: PByte = nil;
2268 ws: TStream = nil;
2269 blk, blkmax: Integer;
2270 //f, c: Integer;
2271 bufsz: Integer = 0;
2272 blksz: Integer;
2273 begin
2274 if (trigbufsz < 0) then
2275 begin
2276 if (mBinBlock < 1) then raise Exception.Create('cannot write binary record without block number');
2277 if (mSize < 1) then raise Exception.Create('cannot write binary record without size');
2278 bufsz := mSize;
2279 end
2280 else
2281 begin
2282 bufsz := trigbufsz;
2283 end;
2284 try
2285 GetMem(buf, bufsz);
2286 FillChar(buf^, bufsz, 0);
2287 ws := TSFSMemoryChunkStream.Create(buf, bufsz);
2289 // write normal fields
2290 for fld in mFields do
2291 begin
2292 // record list?
2293 if (fld.mType = fld.TType.TList) then continue; // later
2294 if fld.mInternal then continue;
2295 if (fld.mBinOfs < 0) then continue;
2296 if (fld.mBinOfs >= bufsz) then raise Exception.Create('binary value offset is outside of the buffer');
2297 TSFSMemoryChunkStream(ws).setup(buf+fld.mBinOfs, bufsz-fld.mBinOfs);
2298 //writeln('writing field <', fld.mName, '>');
2299 fld.writeBinTo(ws);
2300 end;
2302 // write block with normal fields
2303 if mHeader and not onlyFields then
2304 begin
2305 //writeln('writing header...');
2306 // signature and version
2307 writeIntBE(st, LongWord($4D415001));
2308 writeInt(st, Byte(mBinBlock)); // type
2309 writeInt(st, LongWord(0)); // reserved
2310 writeInt(st, LongWord(bufsz)); // size
2311 end;
2312 st.WriteBuffer(buf^, bufsz);
2314 ws.Free(); ws := nil;
2315 FreeMem(buf); buf := nil;
2317 // write other blocks, if any
2318 if mHeader and not onlyFields then
2319 begin
2320 // calculate blkmax
2321 blkmax := 0;
2322 for fld in mFields do
2323 begin
2324 // record list?
2325 if (fld.mType = fld.TType.TList) then
2326 begin
2327 if (fld.mRVal = nil) or (fld.mRVal.count = 0) then continue;
2328 rec := mOwner.findRecType(fld.mName);
2329 if (rec = nil) then continue;
2330 if (rec.mBinBlock <= 0) then continue;
2331 if (blkmax < rec.mBinBlock) then blkmax := rec.mBinBlock;
2332 end;
2333 end;
2334 // write blocks
2335 for blk := 1 to blkmax do
2336 begin
2337 if (blk = mBinBlock) then continue;
2338 ws := nil;
2339 for fld in mFields do
2340 begin
2341 // record list?
2342 if (fld.mType = fld.TType.TList) then
2343 begin
2344 if (fld.mRVal = nil) or (fld.mRVal.count = 0) then continue;
2345 rec := mOwner.findRecType(fld.mName);
2346 if (rec = nil) then continue;
2347 if (rec.mBinBlock <> blk) then continue;
2348 if (ws = nil) then ws := TMemoryStream.Create();
2349 for rv in fld.mRVal do rv.writeBinTo(ws);
2350 end;
2351 end;
2352 // flush block
2353 if (ws <> nil) then
2354 begin
2355 blksz := Integer(ws.position);
2356 ws.position := 0;
2357 writeInt(st, Byte(blk)); // type
2358 writeInt(st, LongWord(0)); // reserved
2359 writeInt(st, LongWord(blksz)); // size
2360 st.CopyFrom(ws, blksz);
2361 ws.Free();
2362 ws := nil;
2363 end;
2364 end;
2365 // write end marker
2366 writeInt(st, Byte(0));
2367 writeInt(st, LongWord(0));
2368 writeInt(st, LongWord(0));
2369 end;
2370 finally
2371 ws.Free();
2372 if (buf <> nil) then FreeMem(buf);
2373 end;
2374 end;
2377 procedure TDynRecord.writeTo (wr: TTextWriter; putHeader: Boolean=true);
2378 var
2379 fld: TDynField;
2380 rec: TDynRecord;
2381 begin
2382 if putHeader then
2383 begin
2384 wr.put(mName);
2385 if (Length(mId) > 0) then begin wr.put(' '); wr.put(mId); end;
2386 wr.put(' ');
2387 end;
2388 wr.put('{'#10);
2389 wr.indent();
2390 try
2391 for fld in mFields do
2392 begin
2393 // record list?
2394 if (fld.mType = fld.TType.TList) then
2395 begin
2396 if not mHeader then raise Exception.Create('record list in non-header record');
2397 if (fld.mRVal <> nil) then
2398 begin
2399 for rec in fld.mRVal do
2400 begin
2401 if (Length(rec.mId) = 0) then continue;
2402 wr.putIndent();
2403 rec.writeTo(wr, true);
2404 end;
2405 end;
2406 continue;
2407 end;
2408 if fld.mInternal then continue;
2409 if fld.mOmitDef and fld.isDefaultValue then continue;
2410 wr.putIndent();
2411 fld.writeTo(wr);
2412 end;
2413 finally
2414 wr.unindent();
2415 end;
2416 wr.putIndent();
2417 wr.put('}'#10);
2418 end;
2421 {$IF DEFINED(D2D_DYNREC_PROFILER)}
2422 var
2423 profCloneRec: UInt64 = 0;
2424 profFindRecType: UInt64 = 0;
2425 profFieldSearching: UInt64 = 0;
2426 profListDupChecking: UInt64 = 0;
2427 profAddRecByType: UInt64 = 0;
2428 profFieldValParsing: UInt64 = 0;
2429 profFixDefaults: UInt64 = 0;
2430 profRecValParse: UInt64 = 0;
2432 procedure xdynDumpProfiles ();
2433 begin
2434 writeln('=== XDYNREC PROFILES ===');
2435 writeln('record cloning: ', profCloneRec div 1000, '.', profCloneRec mod 1000, ' milliseconds');
2436 writeln('findRecType : ', profFindRecType div 1000, '.', profFindRecType mod 1000, ' milliseconds');
2437 writeln('field[] : ', profFieldSearching div 1000, '.', profFieldSearching mod 1000, ' milliseconds');
2438 writeln('list dup check: ', profListDupChecking div 1000, '.', profListDupChecking mod 1000, ' milliseconds');
2439 writeln('addRecByType : ', profAddRecByType div 1000, '.', profAddRecByType mod 1000, ' milliseconds');
2440 writeln('field valparse: ', profFieldValParsing div 1000, '.', profFieldValParsing mod 1000, ' milliseconds');
2441 writeln('fix defaults : ', profFixDefaults div 1000, '.', profFixDefaults mod 1000, ' milliseconds');
2442 writeln('recvalparse : ', profRecValParse div 1000, '.', profRecValParse mod 1000, ' milliseconds');
2443 end;
2444 {$ENDIF}
2447 procedure TDynRecord.parseValue (pr: TTextParser; beginEaten: Boolean=false);
2448 var
2449 fld: TDynField;
2450 rec: TDynRecord = nil;
2451 trc{, rv}: TDynRecord;
2452 {$IF DEFINED(D2D_DYNREC_PROFILER)}
2453 stt, stall: UInt64;
2454 {$ENDIF}
2455 begin
2456 if (mOwner = nil) then raise Exception.Create(Format('can''t parse record ''%s'' value without owner', [mName]));
2458 {$IF DEFINED(D2D_DYNREC_PROFILER)}stall := curTimeMicro();{$ENDIF}
2460 // not a header?
2461 if not mHeader then
2462 begin
2463 // id?
2464 if (not beginEaten) and (pr.tokType = pr.TTId) then mId := pr.expectId();
2465 end
2466 else
2467 begin
2468 assert(mHeaderRec = self);
2469 end;
2471 //writeln('parsing record <', mName, '>');
2472 if not beginEaten then pr.expectTT(pr.TTBegin);
2473 while (pr.tokType <> pr.TTEnd) do
2474 begin
2475 if (pr.tokType <> pr.TTId) then raise Exception.Create('identifier expected');
2476 //writeln('<', mName, '.', pr.tokStr, '>');
2478 // records
2479 if mHeader then
2480 begin
2481 // add records with this type (if any)
2482 {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2483 trc := mOwner.findRecType(pr.tokStr);
2484 {$IF DEFINED(D2D_DYNREC_PROFILER)}profFindRecType := curTimeMicro()-stt;{$ENDIF}
2485 if (trc <> nil) then
2486 begin
2487 {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2488 rec := trc.clone();
2489 {$IF DEFINED(D2D_DYNREC_PROFILER)}profCloneRec := curTimeMicro()-stt;{$ENDIF}
2490 rec.mHeaderRec := mHeaderRec;
2491 try
2492 pr.skipToken();
2493 rec.parseValue(pr);
2494 (*
2495 if (Length(rec.mId) > 0) then
2496 begin
2497 {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2498 fld := field[pr.tokStr];
2499 {$IF DEFINED(D2D_DYNREC_PROFILER)}profFieldSearching := curTimeMicro()-stt;{$ENDIF}
2500 (*
2501 if (fld <> nil) and (fld.mRVal <> nil) then
2502 begin
2503 {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2504 //idtmp := trc.mName+':'+rec.mId;
2505 //if ids.put(idtmp, 1) then raise Exception.Create(Format('duplicate thing ''%s'' in record ''%s''', [fld.mName, mName]));
2506 if fld.mRHash.has(rec.mId) then raise Exception.Create(Format('duplicate thing ''%s'' in record ''%s''', [fld.mName, mName]));
2507 {$IF DEFINED(D2D_DYNREC_PROFILER)}profListDupChecking := curTimeMicro()-stt;{$ENDIF}
2508 end;
2509 end;
2510 *)
2511 {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2512 addRecordByType(rec.mName, rec);
2513 {$IF DEFINED(D2D_DYNREC_PROFILER)}profAddRecByType := curTimeMicro()-stt;{$ENDIF}
2514 rec := nil;
2515 finally
2516 rec.Free();
2517 end;
2518 continue;
2519 end;
2520 end;
2522 // fields
2523 {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2524 fld := field[pr.tokStr];
2525 {$IF DEFINED(D2D_DYNREC_PROFILER)}profFieldSearching := curTimeMicro()-stt;{$ENDIF}
2526 if (fld <> nil) then
2527 begin
2528 if fld.defined then raise Exception.Create(Format('duplicate field ''%s'' in record ''%s''', [fld.mName, mName]));
2529 if fld.internal then raise Exception.Create(Format('internal field ''%s'' in record ''%s''', [fld.mName, mName]));
2530 pr.skipToken();
2531 {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2532 fld.parseValue(pr);
2533 {$IF DEFINED(D2D_DYNREC_PROFILER)}profFieldValParsing := curTimeMicro()-stt;{$ENDIF}
2534 continue;
2535 end;
2537 // something is wrong
2538 raise Exception.Create(Format('unknown field ''%s'' in record ''%s''', [pr.tokStr, mName]));
2539 end;
2540 pr.expectTT(pr.TTEnd);
2541 // fix field defaults
2542 {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
2543 for fld in mFields do fld.fixDefaultValue();
2544 {$IF DEFINED(D2D_DYNREC_PROFILER)}profFixDefaults := curTimeMicro()-stt;{$ENDIF}
2545 //writeln('done parsing record <', mName, '>');
2546 //{$IF DEFINED(D2D_DYNREC_PROFILER)}writeln('stall: ', curTimeMicro()-stall);{$ENDIF}
2547 {$IF DEFINED(D2D_DYNREC_PROFILER)}profRecValParse := curTimeMicro()-stall;{$ENDIF}
2548 end;
2551 // ////////////////////////////////////////////////////////////////////////// //
2552 constructor TDynEBS.Create (pr: TTextParser);
2553 begin
2554 cleanup();
2555 parseDef(pr);
2556 end;
2559 destructor TDynEBS.Destroy ();
2560 begin
2561 cleanup();
2562 inherited;
2563 end;
2566 procedure TDynEBS.cleanup ();
2567 begin
2568 mIsEnum := false;
2569 mName := '';
2570 mIds := nil;
2571 mVals := nil;
2572 mMaxName := '';
2573 mMaxVal := 0;
2574 end;
2577 function TDynEBS.findByName (const aname: AnsiString): Integer;
2578 begin
2579 result := 0;
2580 while (result < Length(mIds)) do
2581 begin
2582 if StrEqu(aname, mIds[result]) then exit;
2583 Inc(result);
2584 end;
2585 result := -1;
2586 end;
2589 function TDynEBS.hasByName (const aname: AnsiString): Boolean; inline;
2590 begin
2591 result := (findByName(aname) >= 0);
2592 end;
2595 function TDynEBS.getFieldByName (const aname: AnsiString): Integer; inline;
2596 var
2597 f: Integer;
2598 begin
2599 f := findByName(aname);
2600 if (f >= 0) then result := mVals[f] else result := 0;
2601 end;
2604 function TDynEBS.definition (): AnsiString;
2605 var
2606 f, cv: Integer;
2607 begin
2608 if mIsEnum then result :='enum ' else result := 'bitset ';
2609 result += mName;
2610 result += ' {'#10;
2611 // fields
2612 if mIsEnum then cv := 0 else cv := 1;
2613 for f := 0 to High(mIds) do
2614 begin
2615 if (mIds[f] = mMaxName) then continue;
2616 result += ' '+mIds[f];
2617 if (mVals[f] <> cv) then
2618 begin
2619 result += Format(' = %d', [mVals[f]]);
2620 if mIsEnum then cv := mVals[f];
2621 result += ','#10;
2622 end
2623 else
2624 begin
2625 result += Format(', // %d'#10, [mVals[f]]);
2626 end;
2627 if mIsEnum then Inc(cv) else if (mVals[f] = cv) then cv := cv shl 1;
2628 end;
2629 // max field
2630 if (Length(mMaxName) > 0) then result += ' '+mMaxName+' = MAX,'#10;
2631 result += '}';
2632 end;
2635 function TDynEBS.pasdef (): AnsiString;
2636 var
2637 f: Integer;
2638 begin
2639 result := '// '+mName+#10'const'#10;
2640 // fields
2641 for f := 0 to High(mIds) do
2642 begin
2643 result += formatstrf(' %s = %d;'#10, [mIds[f], mVals[f]]);
2644 end;
2645 end;
2648 function TDynEBS.nameByValue (v: Integer): AnsiString;
2649 var
2650 f: Integer;
2651 begin
2652 for f := 0 to High(mVals) do
2653 begin
2654 if (mVals[f] = v) then begin result := mIds[f]; exit; end;
2655 end;
2656 result := '';
2657 end;
2660 procedure TDynEBS.parseDef (pr: TTextParser);
2661 var
2662 idname: AnsiString;
2663 cv, v: Integer;
2664 f: Integer;
2665 skipAdd: Boolean;
2666 hasV: Boolean;
2667 begin
2668 if pr.eatId('enum') then mIsEnum := true
2669 else if pr.eatId('bitset') then mIsEnum := false
2670 else pr.expectId('enum');
2671 mName := pr.expectId();
2672 mMaxVal := Integer($80000000);
2673 if mIsEnum then cv := 0 else cv := 1;
2674 pr.expectTT(pr.TTBegin);
2675 while (pr.tokType <> pr.TTEnd) do
2676 begin
2677 idname := pr.expectId();
2678 for f := 0 to High(mIds) do
2679 begin
2680 if StrEqu(mIds[f], idname) then raise Exception.Create(Format('duplicate field ''%s'' in enum/bitset ''%s''', [idname, mName]));
2681 end;
2682 if StrEqu(mMaxName, idname) then raise Exception.Create(Format('duplicate field ''%s'' in enum/bitset ''%s''', [idname, mName]));
2683 skipAdd := false;
2684 hasV := false;
2685 v := cv;
2686 // has value?
2687 if pr.eatDelim('=') then
2688 begin
2689 if pr.eatId('MAX') then
2690 begin
2691 if (Length(mMaxName) > 0) then raise Exception.Create(Format('duplicate max field ''%s'' in enum/bitset ''%s''', [idname, mName]));
2692 mMaxName := idname;
2693 skipAdd := true;
2694 end
2695 else
2696 begin
2697 v := pr.expectInt();
2698 if mIsEnum then cv := v;
2699 hasV := true;
2700 end;
2701 end;
2702 // append it?
2703 if not skipAdd then
2704 begin
2705 // fix maxvalue
2706 if mIsEnum or (not hasV) then
2707 begin
2708 if (mMaxVal < v) then mMaxVal := v;
2709 end;
2710 SetLength(mIds, Length(mIds)+1);
2711 mIds[High(mIds)] := idname;
2712 SetLength(mVals, Length(mIds));
2713 mVals[High(mVals)] := v;
2714 // next cv
2715 if mIsEnum or (not hasV) then
2716 begin
2717 if mIsEnum then Inc(cv) else cv := cv shl 1;
2718 end;
2719 end;
2720 if (pr.tokType = pr.TTEnd) then break;
2721 pr.expectTT(pr.TTComma);
2722 while pr.eatTT(pr.TTComma) do begin end;
2723 end;
2724 pr.expectTT(pr.TTEnd);
2725 // add max field
2726 if (Length(mMaxName) > 0) then
2727 begin
2728 SetLength(mIds, Length(mIds)+1);
2729 mIds[High(mIds)] := mMaxName;
2730 SetLength(mVals, Length(mIds));
2731 mVals[High(mVals)] := mMaxVal;
2732 end;
2733 end;
2736 // ////////////////////////////////////////////////////////////////////////// //
2737 constructor TDynMapDef.Create (pr: TTextParser);
2738 begin
2739 recTypes := TDynRecList.Create();
2740 trigTypes := TDynRecList.Create();
2741 ebsTypes := TDynEBSList.Create();
2742 parseDef(pr);
2743 end;
2746 destructor TDynMapDef.Destroy ();
2747 var
2748 rec: TDynRecord;
2749 ebs: TDynEBS;
2750 begin
2751 for rec in recTypes do rec.Free();
2752 for rec in trigTypes do rec.Free();
2753 for ebs in ebsTypes do ebs.Free();
2754 recTypes.Free();
2755 trigTypes.Free();
2756 ebsTypes.Free();
2757 recTypes := nil;
2758 trigTypes := nil;
2759 ebsTypes := nil;
2760 inherited;
2761 end;
2764 function TDynMapDef.getHeaderRecType (): TDynRecord; inline;
2765 begin
2766 if (recTypes.count = 0) then raise Exception.Create('no header in empty mapdef');
2767 result := recTypes[0];
2768 end;
2771 function TDynMapDef.findRecType (const aname: AnsiString): TDynRecord;
2772 var
2773 rec: TDynRecord;
2774 begin
2775 for rec in recTypes do
2776 begin
2777 if StrEqu(rec.name, aname) then begin result := rec; exit; end;
2778 end;
2779 result := nil;
2780 end;
2783 function TDynMapDef.findTrigFor (const aname: AnsiString): TDynRecord;
2784 var
2785 rec: TDynRecord;
2786 begin
2787 for rec in trigTypes do
2788 begin
2789 if (rec.isForTrig[aname]) then begin result := rec; exit; end;
2790 end;
2791 result := nil;
2792 end;
2795 function TDynMapDef.findEBSType (const aname: AnsiString): TDynEBS;
2796 var
2797 ebs: TDynEBS;
2798 begin
2799 for ebs in ebsTypes do
2800 begin
2801 if StrEqu(ebs.name, aname) then begin result := ebs; exit; end;
2802 end;
2803 result := nil;
2804 end;
2807 procedure TDynMapDef.parseDef (pr: TTextParser);
2808 var
2809 rec, hdr: TDynRecord;
2810 eb: TDynEBS;
2811 f: Integer;
2813 // setup header links and type links
2814 procedure linkRecord (rec: TDynRecord);
2815 var
2816 fld: TDynField;
2817 begin
2818 rec.mHeaderRec := recTypes[0];
2819 for fld in rec.mFields do
2820 begin
2821 if (fld.mType = fld.TType.TTrigData) then continue;
2822 case fld.mEBS of
2823 TDynField.TEBS.TNone: begin end;
2824 TDynField.TEBS.TRec:
2825 begin
2826 fld.mEBSType := findRecType(fld.mEBSTypeName);
2827 if (fld.mEBSType = nil) then raise Exception.Create(Format('field ''%s'' of type ''%s'' has no correcponding record definition', [fld.mName, fld.mEBSTypeName]));
2828 end;
2829 TDynField.TEBS.TEnum,
2830 TDynField.TEBS.TBitSet:
2831 begin
2832 fld.mEBSType := findEBSType(fld.mEBSTypeName);
2833 if (fld.mEBSType = nil) then raise Exception.Create(Format('field ''%s'' of type ''%s'' has no correcponding enum/bitset', [fld.mName, fld.mEBSTypeName]));
2834 if ((fld.mEBS = TDynField.TEBS.TEnum) <> (fld.mEBSType as TDynEBS).mIsEnum) then raise Exception.Create(Format('field ''%s'' of type ''%s'' enum/bitset type conflict', [fld.mName, fld.mEBSTypeName]));
2835 end;
2836 end;
2837 end;
2838 end;
2840 // setup default values
2841 procedure fixRecordDefaults (rec: TDynRecord);
2842 var
2843 fld: TDynField;
2844 begin
2845 for fld in rec.mFields do if fld.mHasDefault then fld.parseDefaultValue();
2846 end;
2848 begin
2849 hdr := nil;
2850 while true do
2851 begin
2852 if not pr.skipBlanks() then break;
2853 if (pr.tokType <> pr.TTId) then raise Exception.Create('identifier expected');
2855 if (pr.tokStr = 'enum') or (pr.tokStr = 'bitset') then
2856 begin
2857 eb := TDynEBS.Create(pr);
2858 if (findEBSType(eb.name) <> nil) then
2859 begin
2860 eb.Free();
2861 raise Exception.Create(Format('duplicate enum/bitset ''%s''', [eb.name]));
2862 end;
2863 eb.mOwner := self;
2864 ebsTypes.append(eb);
2865 //writeln(eb.definition); writeln;
2866 continue;
2867 end;
2869 if (pr.tokStr = 'TriggerData') then
2870 begin
2871 rec := TDynRecord.Create(pr);
2872 for f := 0 to High(rec.mTrigTypes) do
2873 begin
2874 if (findTrigFor(rec.mTrigTypes[f]) <> nil) then
2875 begin
2876 rec.Free();
2877 raise Exception.Create(Format('duplicate trigdata ''%s''', [rec.mTrigTypes[f]]));
2878 end;
2879 end;
2880 rec.mOwner := self;
2881 trigTypes.append(rec);
2882 //writeln(dr.definition); writeln;
2883 continue;
2884 end;
2886 rec := TDynRecord.Create(pr);
2887 //writeln(dr.definition); writeln;
2888 if (findRecType(rec.name) <> nil) then begin rec.Free(); raise Exception.Create(Format('duplicate record ''%s''', [rec.name])); end;
2889 if (hdr <> nil) and StrEqu(rec.name, hdr.name) then begin rec.Free(); raise Exception.Create(Format('duplicate record ''%s''', [rec.name])); end;
2890 rec.mOwner := self;
2891 if rec.mHeader then
2892 begin
2893 if (hdr <> nil) then begin rec.Free(); raise Exception.Create(Format('duplicate header record ''%s'' (previous is ''%s'')', [rec.name, hdr.name])); end;
2894 hdr := rec;
2895 end
2896 else
2897 begin
2898 recTypes.append(rec);
2899 end;
2900 end;
2902 // put header record to top
2903 if (hdr = nil) then raise Exception.Create('header definition not found in mapdef');
2904 recTypes.append(nil);
2905 for f := recTypes.count-1 downto 1 do recTypes[f] := recTypes[f-1];
2906 recTypes[0] := hdr;
2908 // setup header links and type links
2909 for rec in recTypes do linkRecord(rec);
2910 for rec in trigTypes do linkRecord(rec);
2912 // setup default values
2913 for rec in recTypes do fixRecordDefaults(rec);
2914 for rec in trigTypes do fixRecordDefaults(rec);
2915 end;
2918 // ////////////////////////////////////////////////////////////////////////// //
2919 function TDynMapDef.parseMap (pr: TTextParser): TDynRecord;
2920 var
2921 res: TDynRecord = nil;
2922 begin
2923 result := nil;
2924 try
2925 pr.expectId(headerType.name);
2926 res := headerType.clone();
2927 res.mHeaderRec := res;
2928 res.parseValue(pr);
2929 result := res;
2930 res := nil;
2931 finally
2932 res.Free();
2933 end;
2934 end;
2937 function TDynMapDef.parseBinMap (st: TStream): TDynRecord;
2938 var
2939 res: TDynRecord = nil;
2940 begin
2941 result := nil;
2942 try
2943 res := headerType.clone();
2944 res.mHeaderRec := res;
2945 res.parseBinValue(st);
2946 result := res;
2947 res := nil;
2948 finally
2949 res.Free();
2950 end;
2951 end;
2954 function TDynMapDef.pasdef (): AnsiString;
2955 var
2956 ebs: TDynEBS;
2957 rec: TDynRecord;
2958 fld: TDynField;
2959 needComma: Boolean;
2960 tn: AnsiString;
2961 begin
2962 result := '';
2963 result += '// ////////////////////////////////////////////////////////////////////////// //'#10;
2964 result += '// enums and bitsets'#10;
2965 for ebs in ebsTypes do result += #10+ebs.pasdef();
2966 result += #10#10'// ////////////////////////////////////////////////////////////////////////// //'#10;
2967 result += '// records'#10'type'#10;
2968 for rec in recTypes do
2969 begin
2970 if (rec.mSize < 1) then continue;
2971 result += rec.pasdef();
2972 result += #10;
2973 end;
2974 result += #10#10'// ////////////////////////////////////////////////////////////////////////// //'#10;
2975 result += '// triggerdata'#10'type'#10;
2976 result += ' TTriggerData = record'#10;
2977 result += ' case Byte of'#10;
2978 result += ' 0: (Default: Byte128);'#10;
2979 for rec in trigTypes do
2980 begin
2981 result += ' ';
2982 needComma := false;
2983 for tn in rec.mTrigTypes do
2984 begin
2985 if needComma then result += ', ' else needComma := true;
2986 result += tn;
2987 end;
2988 result += ': ('#10;
2989 for fld in rec.mFields do
2990 begin
2991 if fld.mInternal then continue;
2992 if (fld.mBinOfs < 0) then continue;
2993 result += ' '+fld.pasdef+#10;
2994 end;
2995 result += ' );'#10;
2996 end;
2997 result += ' end;'#10;
2998 end;
3001 function TDynMapDef.pasdefconst (): AnsiString;
3002 var
3003 ebs: TDynEBS;
3004 begin
3005 result := '';
3006 result += '// ////////////////////////////////////////////////////////////////////////// //'#10;
3007 result += '// enums and bitsets'#10;
3008 for ebs in ebsTypes do result += #10+ebs.pasdef();
3009 end;
3012 function TDynMapDef.getTrigTypeCount (): Integer; inline; begin result := trigTypes.count; end;
3013 function TDynMapDef.getTrigTypeAt (idx: Integer): TDynRecord; inline; begin if (idx >= 0) and (idx < trigTypes.count) then result := trigTypes[idx] else result := nil; end;
3016 end.