DEADSOFTWARE

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