X-Git-Url: http://deadsoftware.ru/gitweb?a=blobdiff_plain;f=src%2Fshared%2Fxdynrec.pas;h=e1bd571235d2ba9be15abe8d1e8e1480df4d22a6;hb=8213065ce7c035c3c2bb8d8b90ab423d42c0a5ac;hp=8ebac36188754ef6349bbb7bbc5147a1a0ccfe7a;hpb=923fa980434e55419f35422119af2faae2bf68d7;p=d2df-sdl.git

diff --git a/src/shared/xdynrec.pas b/src/shared/xdynrec.pas
index 8ebac36..e1bd571 100644
--- a/src/shared/xdynrec.pas
+++ b/src/shared/xdynrec.pas
@@ -20,7 +20,7 @@ unit xdynrec;
 interface
 
 uses
-  Classes,
+  Variants, Classes,
   xparser, xstreams, utils, hashtable;
 
 
@@ -105,26 +105,17 @@ type
 
     procedure setIVal (v: Integer); inline;
 
+    function getVar (): Variant;
+    procedure setVar (val: Variant);
+
   protected
     // returns `true` for duplicate record id
     function addListItem (rec: TDynRecord): Boolean; inline;
 
-  public
-    type
-      TListEnumerator = record
-      private
-        mList: TDynRecList;
-        mCurIdx: Integer;
-      public
-        constructor Create (alist: TDynRecList);
-        function MoveNext (): Boolean; inline;
-        function getCurrent (): TDynRecord; inline;
-        property Current: TDynRecord read getCurrent;
-      end;
-
   public
     constructor Create (const aname: AnsiString; atype: TType);
     constructor Create (pr: TTextParser);
+    constructor Create (const aname: AnsiString; val: Variant);
     destructor Destroy (); override;
 
     class function getTypeName (t: TType): AnsiString;
@@ -132,7 +123,7 @@ type
     function definition (): AnsiString;
     function pasdef (): AnsiString;
 
-    function clone (newOwner: TDynRecord=nil): TDynField;
+    function clone (newOwner: TDynRecord=nil; registerIn: TDynRecord=nil): TDynField;
 
     procedure parseValue (pr: TTextParser);
     procedure parseBinValue (st: TStream);
@@ -145,14 +136,14 @@ type
 
     procedure setValue (const s: AnsiString);
 
-    function GetEnumerator (): TListEnumerator;
+    function GetEnumerator (): TDynRecList.TEnumerator; inline;
 
   public
     property pasname: AnsiString read mPasName;
     property name: AnsiString read mName;
     property baseType: TType read mType;
     property negbool: Boolean read mNegBool;
-    property defined: Boolean read mDefined write mDefined;
+    property defined: Boolean read mDefined;
     property internal: Boolean read mInternal write mInternal;
     property hasTPrefix: Boolean read mAsT;
     property separatePasFields: Boolean read mSepPosSize;
@@ -165,7 +156,7 @@ type
     property ebs: TEBS read mEBS;
     property ebstype: TObject read mEBSType;
     property ebstypename: AnsiString read mEBSTypeName; // enum/bitset name
-    property recref: TDynRecord read mRecRef write mRecRef; //FIXME: writing is a hack!
+    property recref: TDynRecord read mRecRef;
     property recrefIndex: Integer read getRecRefIndex; // search for this record in header; -1: not found
     // for lists
     property count: Integer read getListCount;
@@ -174,6 +165,8 @@ type
     // userdata
     property tagInt: Integer read mTagInt write mTagInt;
     property tagPtr: Pointer read mTagPtr write mTagPtr;
+    //
+    property varvalue: Variant read getVar write setVar;
   end;
 
 
@@ -198,6 +191,8 @@ type
     mTagInt: Integer;
     mTagPtr: Pointer;
 
+    mRec2Free: TDynRecList;
+
   private
     procedure parseDef (pr: TTextParser); // parse definition
 
@@ -213,6 +208,8 @@ type
     function getForTrigCount (): Integer; inline;
     function getForTrigAt (idx: Integer): AnsiString; inline;
 
+    procedure regrec (rec: TDynRecord);
+
   protected
     function findRecordByTypeId (const atypename, aid: AnsiString): TDynRecord;
     function findRecordNumByType (const atypename: AnsiString; rc: TDynRecord): Integer;
@@ -229,7 +226,7 @@ type
     function definition (): AnsiString;
     function pasdef (): AnsiString;
 
-    function clone (): TDynRecord;
+    function clone (registerIn: TDynRecord): TDynRecord;
 
     function isSimpleEqu (rec: TDynRecord): Boolean;
 
@@ -245,6 +242,13 @@ type
     // number of records of the given instance
     function instanceCount (const typename: AnsiString): Integer;
 
+    //procedure setUserField (const fldname: AnsiString; v: LongInt);
+    //procedure setUserField (const fldname: AnsiString; v: AnsiString);
+    //procedure setUserField (const fldname: AnsiString; v: Boolean);
+
+    function getUserVar (const aname: AnsiString): Variant;
+    procedure setUserVar (const aname: AnsiString; val: Variant);
+
   public
     property id: AnsiString read mId; // for map parser
     property pasname: AnsiString read mPasName;
@@ -264,6 +268,8 @@ type
     // userdata
     property tagInt: Integer read mTagInt write mTagInt;
     property tagPtr: Pointer read mTagPtr write mTagPtr;
+    // userfields
+    property user[const aname: AnsiString]: Variant read getUserVar write setUserVar;
   end;
 
   TDynEBS = class
@@ -358,29 +364,10 @@ function StrEqu (const a, b: AnsiString): Boolean; inline; begin result := (a =
 
 
 // ////////////////////////////////////////////////////////////////////////// //
-constructor TDynField.TListEnumerator.Create (alist: TDynRecList);
-begin
-  mList := alist;
-  mCurIdx := -1;
-end;
-
-
-function TDynField.TListEnumerator.MoveNext (): Boolean; inline;
+function TDynField.GetEnumerator (): TDynRecList.TEnumerator; inline;
 begin
-  Inc(mCurIdx);
-  result := (mList <> nil) and (mCurIdx < mList.count);
-end;
-
-
-function TDynField.TListEnumerator.getCurrent (): TDynRecord; inline;
-begin
-  result := mList[mCurIdx];
-end;
-
-
-function TDynField.GetEnumerator (): TListEnumerator;
-begin
-  result := TListEnumerator.Create(mRVal);
+  //result := TListEnumerator.Create(mRVal);
+  if (mRVal <> nil) then result := mRVal.GetEnumerator else result := TDynRecList.TEnumerator.Create(nil, 0);
 end;
 
 
@@ -408,6 +395,72 @@ begin
 end;
 
 
+constructor TDynField.Create (const aname: AnsiString; val: Variant);
+  procedure setInt32 (v: LongInt);
+  begin
+    case mType of
+      TType.TBool:
+             if (v = 0) then mIVal := 0
+        else if (v = 1) then mIVal := 1
+        else raise Exception.Create('cannot convert shortint variant to field value');
+      TType.TByte:
+             if (v >= -128) and (v <= 127) then mIVal := v
+        else raise Exception.Create('cannot convert shortint variant to field value');
+      TType.TUByte:
+             if (v >= 0) and (v <= 255) then mIVal := v
+        else raise Exception.Create('cannot convert shortint variant to field value');
+      TType.TShort:
+             if (v >= -32768) and (v <= 32767) then mIVal := v
+        else raise Exception.Create('cannot convert shortint variant to field value');
+      TType.TUShort:
+             if (v >= 0) and (v <= 65535) then mIVal := v
+        else raise Exception.Create('cannot convert shortint variant to field value');
+      TType.TInt:
+        mIVal := v;
+      TType.TUInt:
+        mIVal := v;
+      TType.TString:
+        mSVal := formatstrf('%s', [v]);
+      else
+        raise Exception.Create('cannot convert integral variant to field value');
+    end;
+  end;
+begin
+  mRVal := nil;
+  mRecRef := nil;
+  mRHash := nil;
+  cleanup();
+  mName := aname;
+  case varType(val) of
+    varEmpty: raise Exception.Create('cannot convert empty variant to field value');
+    varNull: raise Exception.Create('cannot convert null variant to field value');
+    varSingle: raise Exception.Create('cannot convert single variant to field value');
+    varDouble: raise Exception.Create('cannot convert double variant to field value');
+    varDecimal: raise Exception.Create('cannot convert decimal variant to field value');
+    varCurrency: raise Exception.Create('cannot convert currency variant to field value');
+    varDate: raise Exception.Create('cannot convert date variant to field value');
+    varOleStr: raise Exception.Create('cannot convert olestr variant to field value');
+    varStrArg: raise Exception.Create('cannot convert stdarg variant to field value');
+    varString: mType := TType.TString;
+    varDispatch: raise Exception.Create('cannot convert dispatch variant to field value');
+    varBoolean: mType := TType.TBool;
+    varVariant: raise Exception.Create('cannot convert variant variant to field value');
+    varUnknown: raise Exception.Create('cannot convert unknown variant to field value');
+    varByte: mType := TType.TUByte;
+    varWord: mType := TType.TUShort;
+    varShortInt: mType := TType.TByte;
+    varSmallint: mType := TType.TShort;
+    varInteger: mType := TType.TInt;
+    varInt64: raise Exception.Create('cannot convert int64 variant to field value');
+    varLongWord: raise Exception.Create('cannot convert longword variant to field value');
+    varQWord: raise Exception.Create('cannot convert uint64 variant to field value');
+    varError: raise Exception.Create('cannot convert error variant to field value');
+    else raise Exception.Create('cannot convert undetermined variant to field value');
+  end;
+  varvalue := val;
+end;
+
+
 destructor TDynField.Destroy ();
 begin
   cleanup();
@@ -452,7 +505,7 @@ begin
 end;
 
 
-function TDynField.clone (newOwner: TDynRecord=nil): TDynField;
+function TDynField.clone (newOwner: TDynRecord=nil; registerIn: TDynRecord=nil): TDynField;
 var
   rec: TDynRecord;
 begin
@@ -469,7 +522,7 @@ begin
   begin
     if (result.mRVal = nil) then result.mRVal := TDynRecList.Create(mRVal.count);
     if (result.mRHash = nil) then result.mRHash := hashNewStrInt();
-    for rec in mRVal do result.addListItem(rec.clone());
+    for rec in mRVal do result.addListItem(rec.clone(registerIn));
   end;
   result.mRecRef := mRecRef;
   result.mMaxDim := mMaxDim;
@@ -505,6 +558,118 @@ begin
 end;
 
 
+function TDynField.getVar (): Variant;
+begin
+  if (mEBS = TEBS.TRec) then begin result := LongInt(getRecRefIndex); exit; end;
+  case mType of
+    TType.TBool: result := (mIVal <> 0);
+    TType.TChar: result := mSVal;
+    TType.TByte: result := ShortInt(mIVal);
+    TType.TUByte: result := Byte(mIVal);
+    TType.TShort: result := SmallInt(mIVal);
+    TType.TUShort: result := Word(mIVal);
+    TType.TInt: result := LongInt(mIVal);
+    TType.TUInt: result := LongWord(mIVal);
+    TType.TString: result := mSVal;
+    TType.TPoint: raise Exception.Create('cannot convert point field to variant');
+    TType.TSize: raise Exception.Create('cannot convert size field to variant');
+    TType.TList: raise Exception.Create('cannot convert list field to variant');
+    TType.TTrigData: raise Exception.Create('cannot convert trigdata field to variant');
+    else result := Unassigned; raise Exception.Create('ketmar forgot to handle some field type');
+  end;
+end;
+
+
+procedure TDynField.setVar (val: Variant);
+  procedure setInt32 (v: LongInt);
+  begin
+    case mType of
+      TType.TBool:
+             if (v = 0) then mIVal := 0
+        else if (v = 1) then mIVal := 1
+        else raise Exception.Create('cannot convert shortint variant to field value');
+      TType.TByte:
+             if (v >= -128) and (v <= 127) then mIVal := v
+        else raise Exception.Create('cannot convert shortint variant to field value');
+      TType.TUByte:
+             if (v >= 0) and (v <= 255) then mIVal := v
+        else raise Exception.Create('cannot convert shortint variant to field value');
+      TType.TShort:
+             if (v >= -32768) and (v <= 32767) then mIVal := v
+        else raise Exception.Create('cannot convert shortint variant to field value');
+      TType.TUShort:
+             if (v >= 0) and (v <= 65535) then mIVal := v
+        else raise Exception.Create('cannot convert shortint variant to field value');
+      TType.TInt:
+        mIVal := v;
+      TType.TUInt:
+        mIVal := v;
+      TType.TString:
+        mSVal := formatstrf('%s', [v]);
+      else
+        raise Exception.Create('cannot convert integral variant to field value');
+    end;
+  end;
+begin
+  case varType(val) of
+    varEmpty: raise Exception.Create('cannot convert empty variant to field value');
+    varNull: raise Exception.Create('cannot convert null variant to field value');
+    varSingle: raise Exception.Create('cannot convert single variant to field value');
+    varDouble: raise Exception.Create('cannot convert double variant to field value');
+    varDecimal: raise Exception.Create('cannot convert decimal variant to field value');
+    varCurrency: raise Exception.Create('cannot convert currency variant to field value');
+    varDate: raise Exception.Create('cannot convert date variant to field value');
+    varOleStr: raise Exception.Create('cannot convert olestr variant to field value');
+    varStrArg: raise Exception.Create('cannot convert stdarg variant to field value');
+    varString:
+      if (mType = TType.TChar) or (mType = TType.TString) then
+      begin
+        mSVal := val;
+      end
+      else
+      begin
+        raise Exception.Create('cannot convert string variant to field value');
+      end;
+    varDispatch: raise Exception.Create('cannot convert dispatch variant to field value');
+    varBoolean:
+      case mType of
+        TType.TBool,
+        TType.TByte,
+        TType.TUByte,
+        TType.TShort,
+        TType.TUShort,
+        TType.TInt,
+        TType.TUInt:
+          if val then mIVal := 1 else mIVal := 0;
+        TType.TString:
+          if val then mSVal := 'true' else mSVal := 'false';
+        else
+          raise Exception.Create('cannot convert boolean variant to field value');
+      end;
+    varVariant: raise Exception.Create('cannot convert variant variant to field value');
+    varUnknown: raise Exception.Create('cannot convert unknown variant to field value');
+    varByte,
+    varWord,
+    varShortInt,
+    varSmallint,
+    varInteger:
+      setInt32(val);
+    varInt64:
+      if (val < Int64(LongInt($80000000))) or (val > LongInt($7FFFFFFF)) then
+        raise Exception.Create('cannot convert boolean variant to field value')
+      else
+        mIVal := LongInt(val);
+    varLongWord:
+      if (val > LongWord($7FFFFFFF)) then raise Exception.Create('cannot convert longword variant to field value')
+      else setInt32(Integer(val));
+    varQWord: raise Exception.Create('cannot convert uint64 variant to field value');
+    varError: raise Exception.Create('cannot convert error variant to field value');
+    else raise Exception.Create('cannot convert undetermined variant to field value');
+  end;
+  mDefined := true;
+end;
+
+
 // won't work for lists
 function TDynField.isSimpleEqu (fld: TDynField): Boolean;
 begin
@@ -734,7 +899,7 @@ var
   ainternal: Boolean;
   omitdef: Boolean;
   defstr: AnsiString;
-  defint: Integer;
+  defint, defint2: Integer;
   hasdefStr: Boolean;
   hasdefInt: Boolean;
   hasdefId: Boolean;
@@ -742,6 +907,7 @@ var
   lebs: TDynField.TEBS;
   unique: Boolean;
   asmonid: Boolean;
+  defech: AnsiChar;
 begin
   fldpasname := '';
   fldname := '';
@@ -755,6 +921,7 @@ begin
   omitdef := false;
   defstr := '';
   defint := 0;
+  defint2 := 0;
   hasdefStr := false;
   hasdefInt := false;
   hasdefId := false;
@@ -836,6 +1003,14 @@ begin
             hasdefInt := true;
             defint := pr.expectInt();
           end;
+        pr.TTDelim:
+          begin
+            hasdefInt := true;
+            if pr.eatDelim('[') then defech := ']' else begin pr.expectDelim('('); defech := ')'; end;
+            defint := pr.expectInt();
+            defint2 := pr.expectInt();
+            pr.expectDelim(defech);
+          end;
         else
           raise Exception.Create(Format('field ''%s'' has invalid default', [fldname]));
       end;
@@ -889,8 +1064,13 @@ begin
   end;
 
        if hasdefStr then self.mDefUnparsed := quoteStr(defstr)
-  else if hasdefInt then self.mDefUnparsed := Format('%d', [defint])
-  else if hasdefId then self.mDefUnparsed := defstr;
+  else if hasdefId then self.mDefUnparsed := defstr
+  else if hasdefInt then
+  begin
+         if (mType = TType.TPoint) then self.mDefUnparsed := Format('(%d %d)', [defint, defint2])
+    else if (mType = TType.TSize) then self.mDefUnparsed := Format('[%d %d]', [defint, defint2])
+    else self.mDefUnparsed := Format('%d', [defint]);
+  end;
 
   self.mHasDefault := (hasdefStr or hasdefId or hasdefInt);
   self.mPasName := fldpasname;
@@ -1238,7 +1418,7 @@ begin
           if (tfld = nil) then raise Exception.Create(Format('triggerdata value for field ''%s'' in record ''%s'' without TriggerType field', [mName, rec.mName]));
           rc := mOwner.mOwner.findTrigFor(tfld.mSVal); // find in mapdef
           if (rc = nil) then raise Exception.Create(Format('triggerdata definition for field ''%s'' in record ''%s'' with type ''%s'' not found', [mName, rec.mName, tfld.mSVal]));
-          rc := rc.clone();
+          rc := rc.clone(mOwner.mHeaderRec);
           rc.mHeaderRec := mOwner.mHeaderRec;
           try
             rc.parseBinValue(st, true);
@@ -1440,7 +1620,7 @@ begin
             if (tfld = nil) then raise Exception.Create(Format('triggerdata value for field ''%s'' in record ''%s'' without ''type'' field', [mName, rec.mName]));
             rc := mOwner.mOwner.findTrigFor(tfld.mSVal); // find in mapdef
             if (rc = nil) then raise Exception.Create(Format('triggerdata definition for field ''%s'' in record ''%s'' with type ''%s'' not found', [mName, rec.mName, tfld.mSVal]));
-            rc := rc.clone();
+            rc := rc.clone(mOwner.mHeaderRec);
             rc.mHeaderRec := mOwner.mHeaderRec;
             //writeln(rc.definition);
             try
@@ -1479,7 +1659,7 @@ begin
           rec := nil;
           if (mEBSType <> nil) and (mEBSType is TDynRecord) then rec := (mEBSType as TDynRecord);
           if (rec = nil) then raise Exception.Create(Format('record type ''%s'' for field ''%s'' not found', [mEBSTypeName, mName]));
-          rc := rec.clone();
+          rc := rec.clone(mOwner.mHeaderRec);
           rc.mHeaderRec := mOwner.mHeaderRec;
           rc.parseValue(pr);
           mRecRef := rc;
@@ -1676,12 +1856,23 @@ begin
   mHeaderRec := nil;
   mTagInt := 0;
   mTagPtr := nil;
+  mRec2Free := nil;
 end;
 
 
 destructor TDynRecord.Destroy ();
+var
+  fld: TDynField;
+  rec: TDynRecord;
 begin
+  if (mRec2Free <> nil) then
+  begin
+    for rec in mRec2Free do if (rec <> self) then rec.Free();
+    mRec2Free.Free();
+    mRec2Free := nil;
+  end;
   mName := '';
+  for fld in mFields do fld.Free();
   mFields.Free();
   mFields := nil;
   {$IF DEFINED(XDYNREC_USE_FIELDHASH)}
@@ -1696,6 +1887,16 @@ begin
 end;
 
 
+procedure TDynRecord.regrec (rec: TDynRecord);
+begin
+  if (rec <> nil) and (rec <> self) then
+  begin
+    if (mRec2Free = nil) then mRec2Free := TDynRecList.Create();
+    mRec2Free.append(rec);
+  end;
+end;
+
+
 procedure TDynRecord.addField (fld: TDynField); inline;
 begin
   if (fld = nil) then raise Exception.Create('cannot append nil field to record');
@@ -1791,7 +1992,7 @@ begin
 end;
 
 
-function TDynRecord.clone (): TDynRecord;
+function TDynRecord.clone (registerIn: TDynRecord): TDynRecord;
 var
   fld: TDynField;
   f: Integer;
@@ -1802,18 +2003,19 @@ begin
   result.mPasName := mPasName;
   result.mName := mName;
   result.mSize := mSize;
+  result.mHeader := mHeader;
+  result.mBinBlock := mBinBlock;
+  result.mHeaderRec := mHeaderRec;
+  result.mTagInt := mTagInt;
+  result.mTagPtr := mTagPtr;
   if (mFields.count > 0) then
   begin
     result.mFields.capacity := mFields.count;
-    for fld in mFields do result.addField(fld.clone(result));
+    for fld in mFields do result.addField(fld.clone(result, registerIn));
   end;
   SetLength(result.mTrigTypes, Length(mTrigTypes));
   for f := 0 to High(mTrigTypes) do result.mTrigTypes[f] := mTrigTypes[f];
-  result.mHeader := mHeader;
-  result.mBinBlock := mBinBlock;
-  result.mHeaderRec := mHeaderRec;
-  result.mTagInt := mTagInt;
-  result.mTagPtr := mTagPtr;
+  if (registerIn <> nil) then registerIn.regrec(result);
 end;
 
 
@@ -1927,6 +2129,35 @@ begin
 end;
 
 
+function TDynRecord.getUserVar (const aname: AnsiString): Variant;
+var
+  fld: TDynField;
+begin
+  fld := getFieldByName(aname);
+  if (fld = nil) then result := Unassigned else result := fld.varvalue;
+end;
+
+
+procedure TDynRecord.setUserVar (const aname: AnsiString; val: Variant);
+var
+  fld: TDynField;
+begin
+  fld := getFieldByName(aname);
+  if (fld = nil) then
+  begin
+    if (Length(aname) = 0) then raise Exception.Create('cannot create nameless user field');
+    fld := TDynField.Create(aname, val);
+    fld.mOwner := self;
+    fld.mInternal := true;
+    addField(fld);
+  end
+  else
+  begin
+    fld.varvalue := val;
+  end;
+end;
+
+
 procedure TDynRecord.parseDef (pr: TTextParser);
 var
   fld: TDynField;
@@ -2159,7 +2390,7 @@ begin
             for f := 0 to (bsize div rec.mSize)-1 do
             begin
               mst.setup(buf+f*rec.mSize, rec.mSize);
-              rec := rect.clone();
+              rec := rect.clone(self);
               rec.mHeaderRec := self;
               rec.parseBinValue(mst);
               rec.mId := Format('%s%d', [rec.mName, f]);
@@ -2427,7 +2658,7 @@ begin
       if (trc <> nil) then
       begin
         {$IF DEFINED(D2D_DYNREC_PROFILER)}stt := curTimeMicro();{$ENDIF}
-        rec := trc.clone();
+        rec := trc.clone(mHeaderRec);
         {$IF DEFINED(D2D_DYNREC_PROFILER)}profCloneRec := curTimeMicro()-stt;{$ENDIF}
         rec.mHeaderRec := mHeaderRec;
         try
@@ -2865,7 +3096,7 @@ begin
   result := nil;
   try
     pr.expectId(headerType.name);
-    res := headerType.clone();
+    res := headerType.clone(nil);
     res.mHeaderRec := res;
     res.parseValue(pr);
     result := res;
@@ -2882,7 +3113,7 @@ var
 begin
   result := nil;
   try
-    res := headerType.clone();
+    res := headerType.clone(nil);
     res.mHeaderRec := res;
     res.parseBinValue(st);
     result := res;