DEADSOFTWARE

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