API tools faq
paste
real_het

het.Objects.pas

real_het
Sep 3rd, 2012
115
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Delphi 95.39 KB | None | 0 0
raw download clone embed print report
  1. unit het.Objects;
  2. interface
  3.  
  4. uses windows, sysutils, classes, typinfo, generics.Collections, variants,
  5.   ansistrings, math, rtti,
  6.   het.Utils, het.Arrays, het.Stream, het.TypeInfo, het.Parser;
  7.  
  8. {$DEFINE ENUMERATORS}//qrvafasza, ettol debuggolhatatlanná válik a cucc 2009-en
  9. {$DEFINE NOINCREMENTALNAME}//ihome_uinal nem kell a direktiva (amugy bugos szar ez)
  10.  
  11. {
  12. Event system:
  13.  
  14. a._AddReference(b);
  15.   'a' referencia listajaba bekerul b
  16.  
  17. a._RemoveReference(b);
  18.   'a' referencia listajabol kikerul 'b'
  19.  
  20. a._LinkedObjDestroying(b);
  21.   'a'-nak szol 'b', hogy megszunik
  22.   'a' rajta van 'b' referencia listajan
  23.  
  24. a._SubObjDestroying(b);
  25.   'a'-nak szol 'b', hogy megszunik
  26.   'a' ownerje a 'b'-nek
  27.  
  28. }
  29.  
  30. type
  31.   TId=type integer;
  32.   TName=type ansistring;//soon
  33.   TTime=type single;
  34.   TDate=type integer;
  35.  
  36.   TFieldHash=record
  37.     Hash:integer;
  38.     PropInfo:PPropInfo;
  39.   end;
  40.  
  41.   TClassDescription=class;
  42.   TClassDescriptionCache=class;
  43.  
  44.   TClassDescription=class
  45.   public
  46.     Name:ansistring;
  47.     Hash:integer;
  48.     TypeInfo:PTypeInfo;
  49.     FClass:TClass;
  50.     PropList:PPropList;
  51.     PropListCount:integer;
  52.     IdProp:PPropInfo;//nil, ha nincs, vagy rossz a tipusa
  53.     NameProp:PPropInfo;//nil, ha nincs, vagy rossz a tipusa
  54.     Values,Defaults,Storeds,SubObjects,LinkedObjects,FieldMap:array of PPropInfo;
  55.     StoredRawFieldSizes:array of cardinal;{ha nem 0, akkor lehet kiirni rawban, index megfelel a storeds-nek}
  56.     PackedStoredRawFields:array of record ofs,size,storedId:integer end;{ha size<>0, akkor lehet kiirni rawban, kulonben ofs=index a storeds-ben}
  57.     constructor Create(const ATypeInfo:PTypeInfo;const AClass:TClass);
  58.     destructor Destroy;override;
  59.     function Dump:ansistring;
  60.  
  61.     procedure SetDefaults(const AObject:TObject);
  62.     procedure CreateSubObjs(const AObject:TObject);
  63.     procedure FreeSubObjs(const AObject:TObject);
  64.     procedure ClearLinkedObjs(const AObject:TObject);
  65.     procedure Reset(const AObject:TObject);
  66.   private
  67.     FieldHashArray:THetArray<TFieldHash>;
  68.   public
  69.     function PropInfoByHash(const AHash:integer):PPropInfo;
  70.     function PropInfoByName(const AName:ansistring):PPropInfo;
  71.  
  72. //    function StoredDef:ansistring;
  73.   end;
  74.  
  75.   TClassDescriptionCache=class
  76.   private
  77.     FItems:THetArray<TClassDescription>;
  78.     function AddNew(const ATypeInfo:PTypeInfo;const AClass:TClass):TClassDescription;
  79.   public
  80.     function GetByTypeInfo(const ATypeInfo:PTypeInfo):TClassDescription;
  81.     function GetByClass(const AClass:TClass):TClassDescription;//TClass-t is megjegyzi, nem csak a typeinfo-t
  82.     function GetByHash(const AHash:integer):TClassDescription;
  83.     function GetByName(const AName:ansistring):TClassDescription;
  84.     destructor Destroy;override;
  85.   end;
  86.  
  87. //function ClassDescriptionOf(const AObject:TObject):TClassDescription;overload;
  88. function ClassDescriptionOf(const ATypeInfo:PTypeInfo):TClassDescription;overload;
  89. function ClassDescriptionOf(const AClass:TClass):TClassDescription;overload;
  90. function ClassDescriptionOf(const AClassName:ansistring):TClassDescription;overload;
  91. function ClassDescriptionOf(const AClassNameHash:integer):TClassDescription;overload;
  92.  
  93. procedure RegisterHetClass(const AClass:TClass);overload;deprecated;
  94. procedure RegisterHetClass(const AClasses:array of const);overload;deprecated;
  95.  
  96. Type
  97.   THetObjState=(
  98.     stChangedSave, stChanged0,stChanged1,stChanged2,stChanged3,
  99.     stListActive{accepts objs}, stListClearing, stListNonUniform
  100.   );
  101.   THetObjStates=set of THetObjState;
  102.  
  103. const
  104.   stChangedAll=[stChanged0,stChanged1,stChanged2,stChanged3];
  105.  
  106. type
  107.   THetObject=class;
  108.   THetObjectClass=class of THetObject;
  109.   THetObjectList=class;
  110.  
  111.   TChangeRec=packed record
  112.     Obj:THetObject;
  113.   end;
  114.   TChangeType=(ctCreate,ctChange,ctDestroy);
  115.  
  116.   TSerializeType=(stBin,stDfm);
  117.  
  118.   THetObject=class(TPersistent)
  119.   public
  120.     FOwner:THetObject;
  121.     FReferences:THetArray<THetObject>;
  122.     ObjState:THetObjStates;
  123.   protected
  124.     procedure AfterCreate;virtual;
  125.   public
  126.     class function ClassDesc:TClassDescription;{inline;}
  127.     constructor Create(const AOwner:THetObject);virtual;
  128.     destructor Destroy;override;
  129.  
  130.     function getLookupList(const PropInfo:PPropInfo):THetObjectList;virtual;
  131.     function GetId:TId;
  132.     procedure SetId(const AId:TId);
  133.     function getIndex:integer;
  134.     procedure setIndex(const newIdx:integer);
  135.     function GetName:TName;
  136.     procedure SetName(const AName:TName);
  137.     procedure Serialize(const st:TIO;const SerType:TSerializeType);virtual;
  138.  
  139.     function SubObjName:AnsiString;
  140.     property Owner:THetObject read FOwner;
  141.   public
  142.     procedure _AddReference(const AObj:THetObject);
  143.     procedure _RemoveReference(const AObj:THetObject);
  144.  
  145.     procedure NotifyChange;virtual;//ezt hivja a set metodus, kotelezoen virtual
  146.     procedure NotifyCreate;virtual;
  147.     procedure NotifyDestroy;virtual;
  148.     procedure ChangeEventDispatcher(const AObj:THetObject;const AChangeType:TChangeType);virtual;//ez szorja szet
  149.     procedure ObjectChanged(const AObj:THetObject;const AChangeType:TChangeType);virtual;//ez meg feldolgozhatja
  150.  
  151.     procedure _LinkedObjDestroying(const AObj:THetObject);
  152.     procedure _SubObjDestroying(const AObj:THetObject);virtual;
  153.  
  154.     procedure _SetID(const AID:integer);
  155.   public
  156.     function getFieldAsVariant(const AFieldName:ansistring):Variant;
  157.     procedure setFieldAsVariant(const AFieldName:ansistring;const Value:Variant);
  158.     property Field[const AFieldName:ansistring]:variant read getFieldAsVariant write setFieldAsVariant;
  159.     property Index:integer read GetIndex;
  160.   public
  161.     procedure Reset;virtual;
  162.     procedure LoadFromStr(const Data:RawByteString);
  163.     function SaveToStr(const serType:TSerializeType):RawByteString;
  164.  
  165.     function TryLoadFromFile(const FN:string):boolean;
  166.     procedure LoadFromFile(const FN:string);
  167.     procedure SaveToFile(const serType:TSerializeType;const FN:string);
  168.   public
  169. {    function FieldCount:integer;
  170.     function FieldByName(const AName:ansistring):integer;
  171.     function GetFieldValue(const FieldIdx:integer):variant;overload;
  172.     procedure SetFieldValue(const FieldIdx:integer;const Value:variant);overload;
  173.     function GetFieldValue(const FieldName:AnsiString):variant;overload;
  174.     procedure SetFieldValue(const FieldName:AnsiString;const Value:variant);overload;
  175.     property FieldValue[idx:integer]read GetFieldByName write SetFieldByName;}
  176.  
  177.   published
  178.   public
  179.     function dump(const AIndent:integer=0):ansistring;virtual;
  180.     function IsNil:boolean;inline;
  181.   end;
  182.  
  183.   THetObjectComparerFunct=TComparerFunct<THetObject>;
  184.  
  185.   THetObjectViewSettings=class
  186.   private
  187.     FHash:integer;
  188.     FDefinition:ansistring;
  189.     FUnique:boolean;
  190.     // id,name
  191.  
  192.     FNameSpace:TNameSpace;
  193.     FCtx:TContext;
  194.     FOrderBy:array of record node:TNodeBase;desc:integer{1:ascending;-1:descending} end;
  195.     FWhereAnd:array of record node:TNodeBase;end;
  196. {    FWhereBinary:array of record node:TObject;value:variant end;
  197.     FWhereAnd:array of TObject;}
  198.  
  199.     FValueStack:array of array of variant;
  200.     procedure PushValues(const values:array of const);
  201.     procedure PopValues;
  202.     procedure SetDefinition(const Value:ansistring);
  203.   public
  204.     destructor Destroy;override;
  205.     procedure Reset;
  206.     function Compare(const a,b:THetObject):integer;
  207.     function Filter(const a:THetObject):boolean;
  208.     function FindValues(const a:THetObject):integer;
  209.     property Definition:ansistring read FDefinition write SetDefinition;
  210.     property Hash:integer read FHash;
  211.     property Unique:boolean read FUnique;
  212.   end;
  213.  
  214.   THetObjectListView=class;
  215.  
  216.   TIdxRange=record St,En:integer end;
  217.  
  218.   TGenericHetObjectList<T:THetObject> =class;
  219.  
  220.   THetObjectList=class(THetObject)
  221.   private
  222.     FItems:THetArray<THetObject>;
  223.     function _RemoveListObj(const AListObj:THetObject):boolean;
  224.     procedure _AppendListObj(const AListObj:THetObject);
  225.     function getNextItemId:integer;
  226.   private
  227.     FViewSettings:THetObjectViewSettings;
  228.     FViews:THetObjectList;
  229.     function GetIsView:boolean;inline;
  230.     procedure Sort;
  231.     procedure CopyItemsFrom(const ASrc:THetObjectList);
  232.     function GetViewByDef(const ADef:ansistring):THetObjectListView;
  233.     function GetViewByHash(const AHash:integer):THetObjectListView;
  234.     function GetViewDefinition: ansistring;
  235.     procedure SetViewDefinition(const Value: ansistring);
  236.     function GetIsViewUnique: boolean;
  237.     function CreateListView: THetObjectListView;virtual;
  238.   private
  239.     FBaseClass:THetObjectClass;
  240.     function GetBaseClass:THetObjectClass;
  241.   public
  242.     property BaseClass:THetObjectClass read FBaseClass;
  243.     function NewUniqueView(const ADef:ansistring) :THetObjectListView;
  244.     function GetViewHash:integer;
  245.     property IsView:boolean read GetIsView;
  246.     property IsViewUnique:boolean read GetIsViewUnique;
  247.     function ViewBase:THetObjectList;
  248.     property View[const ADef:ansistring]:THetObjectListView read GetViewByDef;
  249.     property ViewHash:integer read GetViewHash;
  250.     property ViewDefinition:ansistring read GetViewDefinition write SetViewDefinition;
  251.  
  252.     function ViewAdjustFilter(const ANewFilter: ansistring): THetObjectList;
  253.     function ViewAdjustOrder(const ANewOrder: ansistring): THetObjectList;
  254.     procedure RefreshView;
  255.   public
  256.     procedure _SubObjDestroying(const AObj:THetObject);override;
  257.     function GetByNameCached(const AName:ansistring):THetObject;virtual;
  258.     constructor Create(const AOwner:THetObject);override;
  259.     destructor Destroy;override;
  260.     function IndexOf(const AObj:THetObject):integer;
  261.     function Count:integer;inline;
  262.     procedure Clear;
  263.     function UniqueName(const AName:ansistring='';const AlwaysIndex:boolean=false):ansistring;
  264.     function getNextItemNameFor(const AObj:THetObject):ansistring;//!!!!!!!!!!! ez a ketto ugyanaz!!!!!!!!
  265.  
  266.     //unsafe
  267.     procedure Exchange(const Idx1,Idx2:integer);
  268.     procedure Move(const Idx1,Idx2:integer);
  269.  
  270.     procedure ChangeEventDispatcher(const AObj:THetObject;const AChangeType:TChangeType);override;
  271.     procedure ObjectChanged(const AObj:THetObject;const AChangeType:TChangeType);override;
  272.   public
  273.     function GetHetObjByIndex(const AIdx:integer):THetObject;
  274.     function GetHetObjById(const AId:integer):THetObject;
  275.     function GetHetObjByName(const AName:ansistring):THetObject;
  276.   public
  277.     function dump(const AIndent:integer=0):ansistring;override;
  278.  
  279.     function FindBinaryIdx(const AFields: ansistring;const AValues:array of const):integer;
  280.     function FindBinary(const AFields: ansistring;const AValues:array of const):THetObject;
  281.     function FindBinaryNearestIdx(const AFields: ansistring;const AValues:array of const):integer;
  282.  
  283.     function FindBinaryIdxRange(const AFields: ansistring;const AValues:array of const):TIdxRange;
  284.     function FindBinaryRange(const AFields: ansistring;const AValues:array of const):TArray<THetObject>;
  285.   end;
  286.  
  287.   THetObjectListView=class(THetObjectList)
  288.   private
  289.   published
  290.     property Hash:integer read GetViewHash;
  291.   end;
  292.  
  293.   TGenericHetObjectListView<T:THetObject> =class(THetObjectListView)
  294.   protected
  295.     function GetByIndex(const AIndex:integer):T;
  296.     function GetById(const AId:integer):T;
  297.     function GetByName(const AName:ansistring):T;
  298.   public
  299.     property ByIndex[const AIndex:integer]:T read GetByIndex;default;
  300.     property ById[const AId:integer]:T read GetById;
  301.     property ByName[const AName:ansistring]:T read GetByName;
  302.     procedure ForEach(const proc:TProc<T>);//ujrarendezodes es free ellen is véíd
  303.   {$IFDEF ENUMERATORS}//debuggert ebassza...
  304.     function GetEnumerator:TEnumerator<T>;reintroduce;
  305.   {$ENDIF}
  306.   end;
  307.  
  308. //  TSelectFunct<T:THetObject>=reference to Function(o:T):boolean;
  309.   TGenericHetObjectList<T:THetObject> =class(THetObjectList)
  310.   protected
  311.     function GetByIndex(const AIndex:integer):T;
  312.     function GetById(const AId:integer):T;
  313.     function GetByName(const AName:ansistring):T;
  314.     function CreateListView:THetObjectListView;override;
  315.   public
  316.     constructor Create(const AOwner:THetObject);override;
  317.     property ByIndex[const AIndex:integer]:T read GetByIndex;default;
  318.     property ById[const AId:integer]:T read GetById;
  319.     property ByName[const AName:ansistring]:T read GetByName;
  320.   public
  321.     function GetViewByDef(const ADef:ansistring):TGenericHetObjectListView<T>;
  322.     function ViewBase:TGenericHetObjectList<T>;
  323.     property View[const ADef:ansistring]:TGenericHetObjectListView<T> read GetViewByDef;
  324.     procedure ForEach(const proc:TProc<T>);
  325.     function NewListObj:T;overload;
  326.     function NewListObj(const BaseClass:THetObjectClass):THetObject;overload;
  327.  
  328.   {$IFDEF ENUMERATORS}//debuggert ebassza... 2009-en
  329.     type
  330.       TEnumerator = class(TEnumerator<T>)
  331.       private
  332.         FList:TGenericHetObjectList<T>;
  333.         FIndex:Integer;
  334.       protected
  335.         function DoGetCurrent:T; override;
  336.         function DoMoveNext:Boolean;override;
  337.       public
  338.         constructor Create(AList:TGenericHetObjectList<T>);
  339.       end;
  340.     function GetEnumerator:TEnumerator;reintroduce;
  341.   {$ENDIF}
  342.   end;
  343.  
  344. ////////////////////////////////////////////////////////////////////////////////
  345. ///  HetClassInfo                                                            ///
  346. ////////////////////////////////////////////////////////////////////////////////
  347.  
  348.   THetPropInfo=class(THetObject)
  349.   private
  350.     FId:integer;//namehash
  351.     FName:ansistring;
  352.     FRttiProperty:TRttiProperty;
  353.     FHetTypeRec:THetTypeRec;
  354.   public
  355.     constructor create(const AOwner:THetObject;const ARttiProperty:TRttiProperty);reintroduce;
  356.   published
  357.     property Id:Integer read FId;
  358.     property Name:ansistring read FName;
  359.     property Typ:THetType read FHetTypeRec.Typ;
  360.     property BaseTyp:THetBaseType read FHetTypeRec.BaseTyp;
  361.     property Flags:THetTypeFlags read FHetTypeRec.Flags;
  362.   public
  363.     property RttiProperty:TRttiProperty read FRttiProperty;
  364.     property ObjClass:TClass read FHetTypeRec.ObjClass;
  365.     property EnumNames:TArray<AnsiString> read FHetTypeRec.EnumNames;
  366.   end;
  367.  
  368.   THetPropInfos=class(TGenericHetObjectList<THetPropInfo>)
  369.   end;
  370.  
  371.   THetClassInfo=class(THetObject)
  372.   private
  373.     FId:integer;//hash
  374.     FName:ansistring;
  375.     FRttiType:TRttiType;
  376.     FProps:THetPropInfos;
  377.     FIdProp:THetPropInfo;
  378.     FNameProp:THetPropInfo;
  379.  
  380.     FStoredFieldDefs:TArray<THetFieldDef>;
  381.   public
  382.     constructor create(const AOwner:THetObject;const AClassName:ansistring);reintroduce;
  383.   published
  384.     property Id:integer read FId;
  385.     property Name:ansistring read FName;
  386.     property Props:THetPropInfos read FProps;
  387.   public
  388.     property RttiType:TRttiType read FRttiType;
  389.     property IdProp:THetPropInfo read FIdProp;
  390.     property NameProp:THetPropInfo read FNameProp;
  391.     property StoredFieldDefs:TArray<THetFieldDef> read FStoredFieldDefs;
  392.   end;
  393.  
  394.   THetClassInfoList=class(TGenericHetObjectList<THetClassInfo>)
  395.   end;
  396.  
  397. function HetClassInfo(const AClassName:ansistring):THetClassInfo;overload;
  398. function HetClassInfo(const AClass:TClass):THetClassInfo;overload;
  399.  
  400. procedure WriteObjectBin(const AObject:THetObject;const IO:TIO);
  401. procedure WriteObjectDfm(const AObject:THetObject;const IO:TIO;const AFieldName:ansistring='');
  402.  
  403. procedure ReadObjectPropertiesBin(const AObject:THetObject;const IO:TIO);
  404. procedure ReadObjectPropertiesDfm(const AObject:THetObject;const IO:TIO);
  405.  
  406. procedure ReadObjectProperties(const AObject:THetObject;const IO:TIO);
  407.  
  408. function ReadHetObject(const AOwner:THetObject;const IO:TIO):THetObject;
  409.  
  410. function ClassDescriptionCache:TClassDescriptionCache;
  411.  
  412. procedure WriteObjectDfmFilteredPropsOnly(const AObject:THetObject;const IO:TIO;const AFieldName:ansistring;const AFilter:ansistring;const AFieldPath:ansistring);
  413.  
  414. const
  415.   Root:THetObjectList=nil;//entry
  416.  
  417. /////////// test stuff
  418.  
  419. type
  420.   TIOTestSubObj=class(THetObject)
  421.     private FByte:Byte;procedure SetByte(const Value:byte);published property _Byte:Byte read FByte write SetByte default 251;
  422.   end;
  423.  
  424.   TIOTestNamedObj=class(THetObject)
  425.     private FName:TName;published property Name:TName read FName write SetName;
  426.     private FByte:Byte;procedure SetByte(const Value:byte);
  427.     public procedure SetName(const Value: TName);published property _Byte:Byte read FByte write SetByte default 251;
  428.   end;
  429.   TIOTestNamedObjList=class(TGenericHetObjectList<TIOTestNamedObj>)end;
  430.  
  431.   TIOTestIdedObj=class(THetObject)
  432.     private FId:TId;published property Id:TId read FId write SetId;
  433.     private FByte:Byte;procedure SetByte(const Value:byte);
  434.     published property _Byte:Byte read FByte write SetByte default 251;
  435.   end;
  436.   TIOTestIdedObjList=class(TGenericHetObjectList<TIOTestIdedObj>)end;
  437.  
  438.   TIOTestIndexedObj=class(THetObject)
  439.     private FByte:Byte;procedure SetByte(const Value:byte);published property _Byte:Byte read FByte write SetByte default 251;
  440.   end;
  441.   TIOTestIndexedObjList=class(TGenericHetObjectList<TIOTestIndexedObj>)end;
  442.  
  443.   TIOTestObj=class(THetObject)
  444.     //ordinals
  445.     private FByte:Byte;procedure SetByte(const Value:byte);published property _Byte:Byte read FByte write SetByte default 254;
  446.     private FShortInt:ShortInt;procedure SetShortInt(const Value:ShortInt);published property _ShortInt:ShortInt read FShortInt write SetShortInt default -126;
  447.     private FWord:Word;procedure SetWord(const Value:Word);published property _Word:Word read FWord write SetWord default $fedc;
  448.     private FSmallInt:SmallInt;procedure SetSmallInt(const Value:SmallInt);published property _SmallInt:SmallInt read FSmallInt write SetSmallInt default -32700;
  449.     private Finteger:integer;procedure Setinteger(const Value:integer);published property _integer:integer read Finteger write Setinteger default -$789abcde;
  450.     private Fcardinal:cardinal;procedure Setcardinal(const Value:cardinal);published property _cardinal:cardinal read Fcardinal write Setcardinal default $fedcba98;
  451.     private Fint64:int64;procedure Setint64(const Value:int64);published property _int64:int64 read Fint64 write Setint64 default $-$789abcde;
  452.     private Fuint64:uint64;procedure Setuint64(const Value:uint64);published property _uint64:uint64 read Fuint64 write Setuint64 default $789abcde;
  453.  
  454.     //enums/sets
  455.     private FBoolean:Boolean;procedure SetBoolean(const Value:Boolean);published property _Boolean:Boolean read FBoolean write SetBoolean default true;
  456.     private FIOTestEnum:TIOTestEnum;procedure SetIOTestEnum(const Value:TIOTestEnum);published property _IOTestEnum:TIOTestEnum read FIOTestEnum write SetIOTestEnum default Csutortok;
  457.     private FIOTestSet:TIOTestSet;procedure SetIOTestSet(const Value:TIOTestSet);published property _IOTestSet:TIOTestSet read FIOTestSet write SetIOTestSet default [Szombat,Vasarnap];
  458.  
  459.     //floats
  460.     private FSingle:Single;procedure SetSingle(const Value:Single);published property _Single:Single read FSingle write SetSingle;
  461.     private FDouble:Double;procedure SetDouble(const Value:Double);published property _Double:Double read FDouble write SetDouble;
  462.     private FExtended:Extended;procedure SetExtended(const Value:Extended);published property _Extended:Extended read FExtended write SetExtended;
  463.  
  464.     //dates
  465.     private FDate:TDate;procedure SetDate(const Value:TDate);published property _Date:TDate read FDate write SetDate;
  466.     private FTime:TTime;procedure SetTime(const Value:TTime);published property _Time:TTime read FTime write SetTime;
  467.     private FDateTime:TDateTime;procedure SetDateTime(const Value:TDateTime);published property _DateTime:TDateTime read FDateTime write SetDateTime;
  468.  
  469.     //strings
  470.     private FAnsiString:AnsiString;procedure SetAnsiString(const Value:AnsiString);published property _AnsiString:AnsiString read FAnsiString write SetAnsiString;
  471.     private FUnicodeString:UnicodeString;procedure SetUnicodeString(const Value:UnicodeString);published property _UnicodeString:UnicodeString read FUnicodeString write SetUnicodeString;
  472.  
  473.     //ClassType
  474. //    private FClass:TClass;procedure SetClass(const Value:TClass);published property _Class:TClass read FClass write SetClass;
  475.  
  476.     //objs
  477.     public FSubObj:TIOTestSubObj;procedure SetSubObj(const Value:TIOTestSubObj);published property _SubObj:TIOTestSubObj read FSubObj;
  478.     private FNamedObj:TIOTestNamedObj;procedure SetNamedObj(const Value:TIOTestNamedObj);published property _NamedObj:TIOTestNamedObj read FNamedObj write SetNamedObj;
  479.     private FIDedObj:TIOTestIDedObj;procedure SetIDedObj(const Value:TIOTestIDedObj);published property _IDedObj:TIOTestIDedObj read FIDedObj write SetIDedObj;
  480.     private FIndexedObj:TIOTestIndexedObj;procedure SetIndexedObj(const Value:TIOTestIndexedObj);published property _IndexedObj:TIOTestIndexedObj read FIndexedObj write SetIndexedObj;
  481.   end;
  482.  
  483.  
  484. implementation
  485.  
  486. uses het.Patch, het.Variants, unsSystem
  487. {$IFDEF USEFILESYS},het.FileSys{$ENDIF}
  488. ;
  489.  
  490. ////////////////////////////////////////////////////////////////////////////////
  491. ///  HetTypeInfo                                                             ///
  492. ////////////////////////////////////////////////////////////////////////////////
  493.  
  494. var
  495.   RttiContext:TRttiContext;
  496.   RttiTypes:TArray<TRttiType>;
  497.   HetClassInfoList:THetClassInfoList;
  498.  
  499. function HetClassInfo(const AClassName:ansistring):THetClassInfo;
  500. begin
  501.   if HetClassInfoList=nil then
  502.     HetClassInfoList:=THetClassInfoList.Create(nil);
  503.   result:=HetClassInfoList.ById[Crc32UC(AClassName)];
  504.   if result=nil then
  505.     result:=THetClassInfo.Create(HetClassInfoList,AClassName);
  506. end;
  507.  
  508. function HetClassInfo(const AClass:TClass):THetClassInfo;
  509. begin
  510.   result:=HetClassInfo(AClass.ClassName);
  511. end;
  512.  
  513. { THetPropInfo }
  514.  
  515. constructor THetPropInfo.create(const AOwner: THetObject; const ARttiProperty: TRttiProperty);
  516. begin
  517.   inherited create(AOwner);
  518.   FRttiProperty:=ARttiProperty;
  519.   FName:=FRttiProperty.Name;
  520.   FId:=Crc32UC(FName);
  521.   FHetTypeRec.ImportRttiProperty(FRttiProperty);
  522. end;
  523.  
  524. { THetClassInfo }
  525.  
  526. constructor THetClassInfo.create(const AOwner: THetObject; const AClassName: AnsiString);
  527. var t:TRttiType;
  528.     p:TRttiProperty;
  529.     hpi:THetPropInfo;
  530. begin
  531.   t:=RttiTypeByName(AClassName);
  532.   if t=nil then
  533.     raise Exception.Create('CreateHetClassInfo('+AClassName+') Unknown class');
  534.  
  535.   inherited create(AOwner);
  536.  
  537.   FRttiType:=t;
  538.   FName:=t.Name;
  539.   FId:=Crc32UC(FName);
  540.   NotifyChange;
  541.  
  542.   //import members
  543.   for p in t.GetProperties do if(p.Visibility>=mvPublic)then
  544.     THetPropInfo.create(Props,p);
  545.  
  546.   //storedDefs
  547.   for hpi in Props do if [flField,flStored]<=hpi.Flags then begin
  548.  
  549.     //Id, Name
  550.     case hpi.Typ of
  551.       htId:if IdProp=nil then FIdProp:=hpi
  552.                          else raise Exception.Create('Multiple Id fields');
  553.       htName:if NameProp=nil then FNameProp:=hpi
  554.                              else raise Exception.Create('Multiple Name fields');
  555.     end;
  556.  
  557.     SetLength(FStoredFieldDefs,length(FStoredFieldDefs)+1);
  558.     with FStoredFieldDefs[high(FStoredFieldDefs)]do begin
  559.       Name:=hpi.Name;
  560.       Map:=nil;
  561.       PropInfo:=TRttiInstanceProperty(hpi.RttiProperty).PropInfo;
  562.       Typ:=hpi.FHetTypeRec;
  563.     end;
  564.   end;
  565. end;
  566.  
  567. ////////////////////////////////////////////////////////////////////////////////
  568. //                         ClassDescriptionCache                              //
  569. ////////////////////////////////////////////////////////////////////////////////
  570.  
  571. procedure RegisterHetClass(const AClasses:array of const);deprecated;
  572. var i:integer;
  573. begin
  574.   for i:=0 to high(AClasses)do if AClasses[i].VType=vtClass then
  575.     RegisterHetClass(AClasses[i].VClass);
  576. end;
  577.  
  578. procedure RegisterHetClass(const AClass:TClass);deprecated;
  579. begin
  580.   ClassDescriptionOf(AClass);
  581. end;
  582.  
  583. function ClassDescriptionOf(const ATypeInfo:PTypeInfo):TClassDescription;inline;
  584. begin
  585.   result:=ClassDescriptionCache.GetByTypeInfo(ATypeInfo);
  586. end;
  587.  
  588. function ClassDescriptionOf(const AClass:TClass):TClassDescription;inline;
  589. begin
  590.   Result:=ClassDescriptionCache.GetByClass(AClass);
  591. end;
  592.  
  593. function ClassDescriptionOf(const AClassName:ansistring):TClassDescription;inline;
  594. begin
  595.   Result:=ClassDescriptionCache.GetByHash(Crc32UC(AClassName));
  596. end;
  597.  
  598. function ClassDescriptionOf(const AClassNameHash:integer):TClassDescription;inline;
  599. begin
  600.   result:=ClassDescriptionCache.GetByHash(AClassNameHash);
  601. end;
  602.  
  603.  
  604. {unction IsDescendantOf(Child,Ancestor:PTypeInfo):boolean;
  605. begin
  606.   while Child<>nil do begin
  607.     if Child=Ancestor then exit(true);
  608.     if GetTypeData(Child).ParentInfo=nil then exit(false);
  609.     Child:=GetTypeData(Child).ParentInfo^;
  610.   end;
  611.   result:=false;
  612. end;}
  613.  
  614. (*  type
  615.     TFakeRegGroup = class public
  616.       FClassList: TStringList;
  617.       FAliasList: TStringList;
  618.       FGroupClasses: TList;
  619.       FActive: Boolean;
  620.     end;
  621.  
  622.     TFakeRegGroups = class public
  623.       FGroups: TList;
  624.       FLock: TRTLCriticalSection;
  625.     end;*)
  626.  
  627. { TClassDescription }
  628.  
  629. constructor TClassDescription.Create(const ATypeInfo: PTypeInfo;const AClass:TClass);
  630.  
  631.   procedure MakeFieldHashArray;
  632.   var i,idx:integer;
  633.       tmp:TFieldHash;
  634.   begin
  635.     for i:=0 to high(values)do begin
  636.       tmp.PropInfo:=Values[i];
  637.       tmp.Hash:=Crc32UC(Values[i].Name);
  638.       FieldHashArray.FindBinary(function(const a:TFieldHash):integer begin result:=Cmp(tmp.hash,a.hash)end,idx);
  639.       FieldHashArray.Insert(tmp,idx);
  640.     end;
  641.   end;
  642.  
  643.   procedure AddPackedStored(AOfs,ASize,AStoredId:integer);
  644.   begin
  645.     SetLength(PackedStoredRawFields,length(PackedStoredRawFields)+1);
  646.     with PackedStoredRawFields[high(PackedStoredRawFields)]do begin
  647.       ofs:=AOfs;Size:=ASize;StoredId:=AStoredId;
  648.     end;
  649.   end;
  650.  
  651.   function GetLastPackedOfs:cardinal;
  652.   begin
  653.     if length(PackedStoredRawFields)=0 then exit(0);
  654.     with PackedStoredRawFields[high(PackedStoredRawFields)]do
  655.       if StoredId<0 then result:=ofs+size
  656.                     else result:=0;
  657.   end;
  658.  
  659.   procedure IncPackedStored(ASize:integer);
  660.   begin
  661.     if length(PackedStoredRawFields)>0 then with PackedStoredRawFields[high(PackedStoredRawFields)]do inc(size,ASize);
  662.   end;
  663.  
  664.   function ErrorText(const s:ansistring;pi:PPropInfo=nil):ansistring;
  665.   begin
  666.     result:='TClassDescription.create('+Name+') '+s;
  667.     if pi<>nil then result:=result+' '+pi.Name+' '+TypeDump(pi.PropType^);
  668.   end;
  669.  
  670. var
  671.   i,j: Integer;
  672.   fieldofs:Cardinal;
  673.   changedVMTId:integer;
  674.   bw:Cardinal;
  675. label l1;
  676. begin
  677.   TypeInfo:=ATypeInfo;
  678.   FClass:=AClass;
  679.   Name:=TypeInfo.Name;
  680.   Hash:=Crc32UC(Name);
  681.   PropListCount:=GetPropList(TypeInfo,PropList);
  682.  
  683.   for i:=0 to PropListCount-1 do begin//tamogatott tipusok, amik nem writeonly-ak es index nelkuliek
  684.     with PropList[i]^ do begin
  685.       Assert(GetProc<>nil,
  686.         errortext('Write only property not supported: ',PropList[i]));
  687.       Assert((SetProc=nil)or(SetProc=GetProc)or(cardinal(SetProc)<$FF000000),
  688.         errortext('Invalid set/get combination: ',PropList[i]));
  689.       Assert(cardinal(Index)=$80000000,
  690.         errortext('Indexed property not supported: ',PropList[i]));
  691.       Assert(PropType^.Kind in [tkInteger, tkChar, tkEnumeration, tkFloat,
  692.       tkString, tkSet, tkClass, tkWChar, tkLString, tkWString, tkInt64, tkUString],
  693.         errortext('Unsupported property type: ',PropList[i]));
  694.     end;
  695.     SetLength(Values,length(Values)+1);
  696.     Values[high(Values)]:=PropList[i];
  697.   end;
  698.  
  699.   //check if hetobject
  700.   changedVMTId:=VMTIndex(THetObject,@THetObject.NotifyChange);
  701.   for i:=0 to high(values)do
  702.     if(cardinal(Values[i].SetProc)<$FE000000)and(Values[i].SetProc<>nil)
  703.     and(PByte(values[i].SetProc)^=$55)then//{if unoptimized set}
  704.       PatchPropertySetter(Values[i],changedVMTId,TypeInfo.Name);
  705.  
  706.   for i:=0 to high(Values)do if CompareText('Id',Values[i].Name)=0 then begin
  707.     IdProp:=Values[i];break end;
  708.   if(IdProp<>nil)then begin
  709. {    Assert(Idprop.SetProc=nil,
  710.       errortext('Id must be readonly',IdProp));}
  711.     Assert(cardinal(Idprop.GetProc)>=$FF000000,
  712.       errortext('Id.get must be a field',IdProp));
  713.     Assert((IdProp.PropType^.Kind in [tkInteger])and(GetTypeData(IdProp.PropType^).OrdType in[otULong,otSLong]),
  714.       errortext('Id must be 32bit integer ',IdProp));
  715.   end;
  716.  
  717.   for i:=0 to high(Values)do if CompareText('Name',Values[i].Name)=0 then begin
  718.     NameProp:=Values[i];break end;
  719.   if(NameProp<>nil)then begin
  720.     Assert((NameProp.PropType^.Kind in [tkString,tkWString,tkLString,tkUString]),
  721.       errortext('Name must be string',NameProp));
  722.     Assert(cardinal(Nameprop.GetProc)>=$FF000000,
  723.       errortext('Name.get must be a field',NameProp));
  724.     if(NameProp.SetProc=nil)then try WriteProcessMemory(GetCurrentProcess,@NameProp.setproc,@NameProp.getproc,4,bw)except on EAccessViolation do;end;
  725.   end;
  726.  
  727. {  for i:=0 to high(Values)do if CompareText('Description',Values[i].Name)=0 then begin
  728.     DescriptionProp:=Values[i];break end;
  729.   if(IdProp<>nil)then begin
  730.     Assert((DescriptionProp.PropType^.Kind in [tkString,tkWString,tkLString,tkUString]),
  731.       'Description must be string ',DescriptionProp);
  732.   end;}
  733.  
  734.   for i:=0 to high(Values)do//ezeknek kell a Defaultjait beallitani
  735.     if(Values[i].SetProc<>nil)and(Values[i].PropType^.Kind in [tkInteger, tkChar, tkEnumeration, tkSet, tkWChar])and(cardinal(Values[i].Default)<>$80000000)then begin
  736.       SetLength(Defaults,length(Defaults)+1);
  737.       Defaults[high(Defaults)]:=Values[i];
  738.     end;
  739.  
  740.   for i:=0 to high(Values)do//ezeket lehet hogy menteni kell (Setterrel rendelkezoek plusz readonly fieldeket)
  741.     if(Values[i].StoredProc<>nil)and((Values[i].SetProc<>nil)or(cardinal(Values[i].GetProc)>$FF000000))then begin
  742.       SetLength(Storeds,length(Storeds)+1);
  743.       Storeds[high(Storeds)]:=Values[i];
  744.     end;
  745.  
  746.   setlength(StoredRawFieldSizes,length(Storeds));
  747.   for i:=0 to High(Storeds) do begin
  748.     if cardinal(Storeds[i].GetProc)>=$FF000000 then StoredRawFieldSizes[i]:=TypeSize(Storeds[i].PropType^)
  749.                                                else StoredRawFieldSizes[i]:=0;
  750.   end;
  751.  
  752.   for i:=0 to High(Storeds)do if(StoredRawFieldSizes[i]>0)and(cardinal(Storeds[i].StoredProc)=1)then begin//biztosan stored
  753.     fieldofs:=cardinal(Storeds[i].GetProc)and $FFFFFF;
  754.     if false and(fieldofs=GetLastPackedOfs) then IncPackedStored(StoredRawFieldSizes[i])
  755.                                             else AddPackedStored(fieldofs,StoredRawFieldSizes[i],-1);
  756.   end else begin
  757.     AddPackedStored(0,0,i);
  758.   end;
  759.  
  760.  
  761.   j:=0;for i:=0 to high(Values)do with Values[i]^do
  762.     if cardinal(GetProc)>$FF000000 then j:=max(j,cardinal(GetProc)and $FFFFFF);
  763.   SetLength(FieldMap,j+1);fillchar(FieldMap[0],length(FieldMap)*SizeOf(FieldMap[0]),0);
  764.   for i:=0 to high(Values)do with Values[i]^do
  765.     if cardinal(GetProc)>$FF000000 then FieldMap[cardinal(GetProc)and $FFFFFF]:=Values[i];
  766.  
  767.   for i:=0 to high(values)do if(Values[i].PropType^.Kind=tkClass)then begin
  768. {    Assert(cardinal(values[i].GetProc)>=$FF000000,
  769.       errortext('Class property.get must be a field',Values[i]));  getteres readonly class megengedett}
  770.     if not(cardinal(values[i].GetProc)>=$FF000000) then continue;
  771.     if not(GetTypeData(Values[i].PropType^).ClassType.InheritsFrom(THetObject))then continue;
  772.  
  773.     Assert((values[i].SetProc=nil)or(cardinal(values[i].SetProc)<$FE000000),
  774.       errortext('Class property.set must be nil or static method',Values[i]));
  775.     if Values[i].SetProc=nil then begin
  776.       SetLength(SubObjects,length(SubObjects)+1);
  777.       SubObjects[high(SubObjects)]:=Values[i];
  778.     end else begin
  779.       SetLength(LinkedObjects,length(LinkedObjects)+1);
  780.       LinkedObjects[high(LinkedObjects)]:=Values[i];
  781.     end;
  782.   end;
  783.  
  784. //Propinfo hash list
  785.   MakeFieldHashArray;
  786. end;
  787.  
  788. destructor TClassDescription.Destroy;
  789. begin
  790.   if PropListCount>0 then
  791.     FreeMem(PropList);
  792.   inherited;
  793. end;
  794.  
  795. function TClassDescription.Dump: ansistring;
  796.   procedure a(const s:ansistring);
  797.   begin result:=result+s+#9 end;
  798. var pi:PPropInfo;
  799. {    ti:PTypeInfo;
  800.     td:PTypeData;}
  801.     i:integer;
  802. begin
  803.   result:='';
  804.   a('Name');
  805.   a('Get');
  806.   a('Set');
  807.   a('Stored');
  808.   a('Default');
  809.   a('NameIndex');
  810.   a('TypeInfo');
  811.   result:=result+#13#10;
  812.  
  813.   for i:=0 to PropListCount-1 do begin
  814.     pi:=PropList[i];
  815. //    ti:=pi.PropType^;
  816. //    td:=GetTypeData(ti);
  817.  
  818.     a(pi.Name);
  819.     a('#'+inttohex(cardinal(pi.GetProc),8));
  820.     a('#'+inttohex(cardinal(pi.SetProc),8));
  821.     a('#'+inttohex(cardinal(pi.StoredProc),8));
  822.     a('#'+inttohex(pi.Default,8));
  823.     a(inttostr(pi.NameIndex));
  824.     a(TypeDump(pi.PropType^));
  825.     result:=result+#13#10;
  826.   end;
  827. end;
  828.  
  829. procedure TClassDescription.CreateSubObjs(const AObject:TObject);
  830. var i:integer;
  831. begin
  832.   for i:=0 to high(SubObjects)do begin
  833.     ppointer(cardinal(AObject)+(cardinal(SubObjects[i].GetProc)and $FFFFFF))^:=
  834.       THetObjectClass(getTypeData(SubObjects[i].PropType^).ClassType).Create(THetObject(AObject));
  835.   end;
  836. end;
  837.  
  838. procedure TClassDescription.FreeSubObjs(const AObject:TObject);
  839. var i:integer;
  840.     p:ppointer;
  841. begin
  842.   for i:=high(SubObjects)downto 0 do begin
  843.     p:=ppointer(cardinal(AObject)+(cardinal(SubObjects[i].GetProc)and $FFFFFF));
  844.     if p^<>nil then begin
  845.       FreeAndNil(p^);
  846.     end;
  847.   end;
  848. end;
  849.  
  850. function TClassDescription.PropInfoByHash(const AHash: integer): PPropInfo;
  851. var idx:integer;
  852. begin
  853.   if FieldHashArray.FindBinary(function(const a:TFieldHash):integer begin result:=AHash-a.Hash end,idx)then
  854.     result:=FieldHashArray.FItems[idx].propinfo
  855.   else
  856.     result:=nil;
  857. end;
  858.  
  859. function TClassDescription.PropInfoByName(const AName: ansistring): PPropInfo;
  860. begin
  861.   result:=PropInfoByHash(Crc32UC(AName))
  862. end;
  863.  
  864. procedure TClassDescription.ClearLinkedObjs(const AObject:TObject);
  865. var i:integer;
  866. begin
  867.   for i:=0 to high(LinkedObjects)do begin
  868.     SetOrdProp(AObject,LinkedObjects[i],0);
  869.   end;
  870. end;
  871.  
  872. procedure TClassDescription.Reset(const AObject: TObject);
  873. var i:integer;
  874.     obj:THetObject;
  875. begin
  876.   for i:=0 to high(storeds)do with Storeds[i]^do case PropType^.Kind of
  877.     tkInteger, tkChar, tkEnumeration, tkSet, tkWChar:
  878.       if cardinal(Default)<>$80000000 then SetOrdProp(AObject,storeds[i],Default)
  879.                                       else SetOrdProp(AObject,storeds[i],0);
  880.     tkInt64:SetInt64Prop(AObject,storeds[i],0);
  881.     tkFloat:SetFloatProp(AObject,Storeds[i],0);
  882.     tkString, tkWString, tkUString, tkLString: SetStrProp(AObject,storeds[i],'');
  883.     tkClass:
  884.       if SetProc<>nil then begin
  885.         SetOrdProp(AObject,storeds[i],0)
  886.       end else begin
  887.         obj:=THetObject(GetOrdProp(AObject,storeds[i]));
  888.         ClassDescriptionOf(obj.ClassInfo).Reset(obj);
  889.       end;
  890.   end;
  891.   if AObject is THetObjectList then
  892.     THetObjectList(AObject).Clear;
  893. end;
  894.  
  895. procedure TClassDescription.SetDefaults(const AObject: TObject);
  896. var i:integer;
  897. begin
  898.   for i:=0 to high(Defaults)do
  899.     SetOrdProp(AObject,Defaults[i],Defaults[i].Default);
  900. end;
  901.  
  902. {function TClassDescription.StoredDef: ansistring;
  903. var p:PPropInfo;
  904.     s:ansistring;
  905. begin
  906.   with AnsiStringBuilder(result,true)do
  907.   for p in Storeds do begin
  908. //    AddChar(ansichar(p.PropType);
  909.  
  910.   end;
  911. end;}
  912.  
  913. { TClassDescriptionCache }
  914.  
  915. function TClassDescriptionCache.AddNew(const ATypeInfo:PTypeInfo;const AClass:TClass):TClassDescription;
  916. begin
  917.   result:=TClassDescription.Create(ATypeInfo,AClass);
  918.   FItems.Insert(result,0);
  919. end;
  920.  
  921. destructor TClassDescriptionCache.Destroy;
  922. var i:integer;
  923. begin
  924.   with FItems do for i:=0 to FCount-1 do FItems[i].Free;
  925.   inherited;
  926. end;
  927.  
  928. function TClassDescriptionCache.GetByHash(const AHash: integer): TClassDescription;
  929. var i:integer;cl:TClass;
  930. begin
  931.   with FItems do for i:=0 to FCount-1 do if FItems[i].Hash=AHash then begin
  932.     exit(FItems[i]);
  933.     if i>4 then Move(i,0);
  934.   end;
  935.  
  936.   cl:=het.TypeInfo.ClassByHash(AHash);
  937.   if cl<>nil then result:=AddNew(cl.ClassInfo,cl)
  938.              else result:=nil;
  939. end;
  940.  
  941. function TClassDescriptionCache.GetByName(const AName: ansistring): TClassDescription;
  942. var i:integer;cl:TClass;
  943. begin
  944.   with FItems do for i:=0 to FCount-1 do if AnsiCompareText(FItems[i].Name,AName)=0 then begin
  945.     exit(FItems[i]);
  946.     if i>4 then Move(i,0);
  947.   end;
  948.  
  949.   cl:=het.TypeInfo.ClassByName(AName);
  950.   if cl<>nil then result:=AddNew(cl.ClassInfo,cl)
  951.              else result:=nil;
  952. end;
  953.  
  954. function TClassDescriptionCache.GetByTypeInfo(const ATypeInfo: PTypeInfo): TClassDescription;
  955. var i:integer;
  956. begin
  957.   for i:=0 to FItems.Count-1 do begin
  958.     if FItems.FItems[i].TypeInfo=ATypeInfo then begin
  959.       exit(FItems.FItems[i]);
  960.       if i>4 then FItems.Move(i,0);
  961.     end;
  962.   end;
  963.   result:=AddNew(ATypeInfo,nil);
  964. end;
  965.  
  966. function TClassDescriptionCache.GetByClass(const AClass:TClass): TClassDescription;
  967. var i:integer;
  968. begin
  969.   for i:=0 to FItems.Count-1 do begin
  970.     if FItems.FItems[i].FClass=AClass then begin
  971.       exit(FItems.FItems[i]);
  972.       if i>4 then FItems.Move(i,0);
  973.     end;
  974.   end;
  975.   result:=AddNew(AClass.ClassInfo,AClass);
  976. end;
  977.  
  978. ////////////////////////////////////////////////////////////////////////////////
  979. //                         HETOBJECT                                          //
  980. ////////////////////////////////////////////////////////////////////////////////
  981.  
  982.  
  983. procedure WriteObjectBin(const AObject:THetObject;const IO:TIO);
  984.   procedure WritePropBin(const PropInfo:PPropInfo);
  985.   var
  986.     _ansistring:AnsiString;
  987.     _int:integer;
  988.     _single:Single;
  989.     _double:Double;
  990.     _extended:Extended;
  991.     _comp:Comp;
  992.     _curr:Currency;
  993.     _int64:int64;
  994.     obj:THetObject;
  995.     linkCD:TClassDescription;
  996. //    lookuplist:THetObjectList;
  997.   begin with PropInfo^ do begin
  998.     case PropType^.Kind of
  999.       tkInteger, tkChar, tkEnumeration, tkSet, tkWChar:begin
  1000.         _int:=GetOrdProp(AObject,PropInfo);
  1001.         case GetTypeData(PropType^).OrdType of
  1002.           otSByte,otUByte:IO.IOBlock(_int,1);
  1003.           otSWord,otUWord:IO.IOBlock(_int,2);
  1004.           otSLong,otULong:IO.IOBlock(_int,4);
  1005.         end;
  1006.       end;
  1007.       tkInt64:begin _int64:=GetInt64Prop(AObject,PropInfo);IO.IOBlock(_int64,8);end;
  1008.       tkFloat:case GetTypeData(PropType^).FloatType of
  1009.         ftSingle:  begin _single:=  GetFloatProp(AObject,PropInfo);IO.IOBlock(_single  ,sizeof(_single  ));end;
  1010.         ftDouble:  begin _Double:=  GetFloatProp(AObject,PropInfo);IO.IOBlock(_Double  ,sizeof(_Double  ));end;
  1011.         ftExtended:begin _Extended:=GetFloatProp(AObject,PropInfo);IO.IOBlock(_Extended,sizeof(_Extended));end;
  1012.         ftComp:    begin _Comp:=    GetFloatProp(AObject,PropInfo);IO.IOBlock(_Comp    ,sizeof(_Comp    ));end;
  1013.         ftCurr:    begin _Curr:=    GetFloatProp(AObject,PropInfo);IO.IOBlock(_Curr    ,sizeof(_Curr    ));end;
  1014.       end;
  1015.       tkLString,tkWString,tkUString:begin
  1016.         _ansistring:=GetAnsiStrProp(AObject,PropInfo);
  1017.         IO.IO(_ansistring);
  1018.       end;
  1019.       tkClass:begin
  1020.         obj:=THetObject(pointer(cardinal(AObject)+cardinal(GetProc)and $FFFFFF)^);
  1021.         if SetProc=nil then begin//subobj
  1022.           WriteObjectBin(obj,IO);
  1023.         end else begin//link
  1024.           linkCD:=ClassDescriptionCache.GetByTypeInfo(GetTypeData(PropType^).ClassType.ClassInfo);
  1025.           if linkCD.IdProp<>nil then begin//by id
  1026.             if obj<>nil then begin
  1027.               _int:=GetOrdProp(obj,linkCD.IdProp)//1based
  1028.             end else
  1029.               _int:=0;
  1030.             IO.IOComprCardinal(cardinal(_int));
  1031.           end else if linkCD.NameProp<>nil then begin//by name
  1032.             if obj<>nil then begin
  1033.               _ansistring:=GetAnsiStrProp(obj,linkCD.NameProp)
  1034.             end else
  1035.               _ansistring:='';
  1036.             IO.IO(_ansistring);
  1037.           end else begin//by index
  1038.             if obj<>nil then begin
  1039. //              lookuplist:=AObject.getLookupList(PropInfo);
  1040. //              Assert(lookuplist<>nil,'WritePropBin() can''t get lookuplist');
  1041.               _int:=obj.getIndex{lookuplist.IndexOf(obj)}+1;
  1042.               Assert(_int>0,'WritePropBin() can''t find object in lookuplist');
  1043.             end else
  1044.               _Int:=0;
  1045.             IO.IOComprCardinal(cardinal(_int));
  1046.           end;
  1047.         end;
  1048.       end;
  1049.     end;
  1050.   end;end;
  1051.  
  1052. var CD:TClassDescription;
  1053.     i:Integer;
  1054.     actProp:PPropInfo;
  1055. begin
  1056.   if AObject=nil then begin
  1057.     i:=0;IO.IOBlock(i,4);
  1058.     exit;
  1059.   end;
  1060.   CD:=ClassDescriptionCache.GetByTypeInfo(AObject.ClassInfo);
  1061.   IO.IOBlock(CD.Hash,4);
  1062.   with CD do for i := 0 to high(PackedStoredRawFields)do with PackedStoredRawFields[i]do if storedId<0 then//packed stored
  1063.     IO.IOBlock(pointer(cardinal(AObject)+cardinal(ofs))^,size)
  1064.   else begin
  1065.     actProp:=Storeds[storedId];
  1066.     with actProp^do begin
  1067.       if(cardinal(StoredProc)=1)or IsStoredProp(AObject,actProp)then begin
  1068.         if StoredRawFieldSizes[storedId]>0 then begin//field es raw
  1069.           IO.IOBlock(pointer(cardinal(AObject)+(cardinal(GetProc)and $FFFFFF))^,StoredRawFieldSizes[storedId]);
  1070.         end else begin//method vagy nem_raw
  1071.           WritePropBin(actProp);
  1072.         end;
  1073.       end;
  1074.     end;
  1075.   end;
  1076.   if AObject is THetObjectList then with AObject as THetObjectList do begin
  1077.     IO.IOComprCardinal(cardinal(FItems.FCount));
  1078.     for I:=0 to FItems.FCount-1 do
  1079.       FItems.FItems[i].Serialize(IO,stBin);
  1080.   end;
  1081. end;
  1082.  
  1083. procedure WriteObjectDfm(const AObject:THetObject;const IO:TIO;const AFieldName:ansistring='');
  1084.   procedure WritePropDfm(const PropInfo:PPropInfo);
  1085.  
  1086.     procedure wr(const s:ansistring);
  1087.     begin
  1088.       IO.WriteLine(Propinfo.Name+'='+s);
  1089.     end;
  1090.  
  1091.   var
  1092.     _ansistring:AnsiString;
  1093.     _int:integer;
  1094.     obj:THetObject;
  1095.     linkCD:TClassDescription;
  1096.     lookuplist:THetObjectList;
  1097.     val:Variant;
  1098.     _cardinal:Cardinal;
  1099.   begin with PropInfo^ do begin
  1100.     GetPropValue(AObject,PropInfo,false);
  1101.  
  1102.     case PropType^.Kind of
  1103.       tkClass:begin
  1104.         obj:=THetObject(pointer(cardinal(AObject)+cardinal(GetProc)and $FFFFFF)^);
  1105.         if SetProc=nil then begin//subobj
  1106.           WriteObjectDfm(obj,IO,Propinfo.name);
  1107.         end else begin//link
  1108.           linkCD:=ClassDescriptionCache.GetByTypeInfo(GetTypeData(PropType^).ClassType.ClassInfo);
  1109.           if linkCD.IdProp<>nil then begin//by id
  1110.             if obj<>nil then begin
  1111.               _int:=GetOrdProp(obj,linkCD.IdProp){+1}//1based
  1112.             end else
  1113.               _int:=0;
  1114.             wr(ToStr(_int));
  1115.           end else if linkCD.NameProp<>nil then begin//by name
  1116.             if obj<>nil then begin
  1117.               _ansistring:=GetAnsiStrProp(obj,linkCD.NameProp)
  1118.             end else
  1119.               _ansistring:='';
  1120.             wr(ToPas(_ansistring));
  1121.           end else begin//by index
  1122.             if obj<>nil then begin
  1123.               lookuplist:=AObject.getLookupList(PropInfo);
  1124.               Assert(lookuplist<>nil,'WritePropBin() can''t get lookuplist ('+AObject.ClassName+'.'+PropInfo.Name+')');
  1125.               _int:=lookuplist.IndexOf(obj)+1;
  1126.               Assert(_int>0,'WritePropBin() can''t find object in lookuplist ('+AObject.ClassName+'.'+PropInfo.Name+')');
  1127.             end else
  1128.               _Int:=0;
  1129.             wr(ToStr(_int));
  1130.           end;
  1131.         end;
  1132.       end;
  1133.     tkInteger:begin //cardinal is not int!!
  1134.       val:=GetPropValue(AObject,PropInfo,true);
  1135.       if GetTypeData(Propinfo.PropType^).OrdType=otULong then begin
  1136.         _cardinal:=val;
  1137.         val:=_cardinal;
  1138.       end;
  1139.       wr(ToPas(val));
  1140.     end else
  1141.       val:=GetPropValue(AObject,PropInfo,true);
  1142.       wr(ToPas(val));
  1143.     end;
  1144.   end;end;
  1145.  
  1146. var CD:TClassDescription;
  1147.     i:Integer;
  1148.     actProp:PPropInfo;
  1149. begin
  1150.   if AObject=nil then begin
  1151.     if AFieldName='' then IO.WriteLine('nil')
  1152.                      else IO.WriteLine(AFieldName+'=nil');
  1153.     exit;
  1154.   end;
  1155.   CD:=ClassDescriptionCache.GetByTypeInfo(AObject.ClassInfo);
  1156.   if AFieldName='' then IO.WriteLine('object '+CD.Name)
  1157.                    else IO.WriteLine(AFieldName+'=object '+CD.Name);
  1158.   IO.WriteIndentInc;
  1159.   with CD do for i:=0 to High(Storeds)do begin
  1160.     actProp:=Storeds[i];
  1161.     with actProp^do
  1162.       if(cardinal(StoredProc)=1)or IsStoredProp(AObject,actProp)then
  1163.         WritePropDfm(actProp);
  1164.   end;
  1165.  
  1166.   if AObject is THetObjectList then with AObject as THetObjectList do begin
  1167.     for I:=0 to FItems.FCount-1 do
  1168.       WriteObjectDfm(FItems.FItems[i],IO);
  1169.   end;
  1170.   IO.WriteIndentDec;
  1171.   IO.WriteLine('end');
  1172. end;
  1173.  
  1174. //filter: 'name,Drawbar?.Amount,...'
  1175. procedure WriteObjectDfmFilteredPropsOnly(const AObject:THetObject;const IO:TIO;const AFieldName:ansistring;const AFilter:ansistring;const AFieldPath:ansistring);
  1176.  
  1177.   procedure WritePropDfm(const PropInfo:PPropInfo;const FullPath:ansistring);
  1178.     function PasStr(const s:ansistring):ansistring;
  1179.     begin
  1180.       result:=s;
  1181.       Replace('''','''''',result,[roAll]);
  1182.       result:=''''+s+'''';
  1183.     end;
  1184.  
  1185.     procedure wr(const s:ansistring);
  1186.     begin
  1187.       IO.WriteLine(Propinfo.Name+'='+s);
  1188.     end;
  1189.  
  1190.   var
  1191.     _ansistring:AnsiString;
  1192.     _int:integer;
  1193.     obj:THetObject;
  1194.     linkCD:TClassDescription;
  1195.     lookuplist:THetObjectList;
  1196.     val:Variant;
  1197.  
  1198.   begin with PropInfo^ do begin
  1199.     GetPropValue(AObject,PropInfo,false);
  1200.  
  1201.     case PropType^.Kind of
  1202.       tkClass:begin
  1203.         obj:=THetObject(pointer(cardinal(AObject)+cardinal(GetProc)and $FFFFFF)^);
  1204.         if SetProc=nil then begin//subobj
  1205.           /////!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  1206.           WriteObjectDfmFilteredPropsOnly(obj,IO,Propinfo.name,AFilter,FullPath);
  1207.         end else begin//link
  1208.           linkCD:=ClassDescriptionCache.GetByTypeInfo(GetTypeData(PropType^).ClassType.ClassInfo);
  1209.           if linkCD.IdProp<>nil then begin//by id
  1210.             if obj<>nil then begin
  1211.               _int:=GetOrdProp(obj,linkCD.IdProp){+1}//1based
  1212.             end else
  1213.               _int:=0;
  1214.             wr(ToStr(_int));
  1215.           end else if linkCD.NameProp<>nil then begin//by name
  1216.             if obj<>nil then begin
  1217.               _ansistring:=GetAnsiStrProp(obj,linkCD.NameProp)
  1218.             end else
  1219.               _ansistring:='';
  1220.             wr(PasStr(_ansistring));
  1221.           end else begin//by index
  1222.             if obj<>nil then begin
  1223.               lookuplist:=AObject.getLookupList(PropInfo);
  1224.               Assert(lookuplist<>nil,'WritePropBin() can''t get lookuplist ('+AObject.ClassName+'.'+PropInfo.Name+')');
  1225.               _int:=lookuplist.IndexOf(obj)+1;
  1226.               Assert(_int>0,'WritePropBin() can''t find object in lookuplist ('+AObject.ClassName+'.'+PropInfo.Name+')');
  1227.             end else
  1228.               _Int:=0;
  1229.             wr(ToStr(_int));
  1230.           end;
  1231.         end;
  1232.       end;
  1233.     else
  1234.       val:=GetPropValue(AObject,PropInfo,true);
  1235.       if VarIsStr(val)then wr(PasStr(val))
  1236.                       else wr(ToStr(val));
  1237.     end;
  1238.   end;end;
  1239.  
  1240. var CD:TClassDescription;
  1241.     i:Integer;
  1242.     actProp:PPropInfo;
  1243.     filt,path:ansistring;
  1244. begin
  1245.   if AObject=nil then begin
  1246.     if AFieldName='' then IO.WriteLine('nil')
  1247.                      else IO.WriteLine(AFieldName+'=nil');
  1248.     exit;
  1249.   end;
  1250.   CD:=ClassDescriptionCache.GetByTypeInfo(AObject.ClassInfo);
  1251.   if AFieldName='' then IO.WriteLine('object '+CD.Name)
  1252.                    else IO.WriteLine(AFieldName+'=object '+CD.Name);
  1253.   IO.WriteIndentInc;
  1254.   with CD do for i:=0 to High(Storeds)do begin
  1255.     actProp:=Storeds[i];
  1256.     with actProp^do begin
  1257.       path:=AFieldPath+switch(AFieldPath='','','.')+actProp.name;
  1258.       if(actProp.SetProc=nil)and(actProp.PropType^.Kind=tkClass)then
  1259.         WritePropDfm(actProp,path)
  1260.       else for filt in ListSplit(AFilter,',')do
  1261.         if IsWild2(filt,path)then begin
  1262.           WritePropDfm(actProp,path);
  1263.           break;
  1264.         end;
  1265.     end;
  1266.   end;
  1267.  
  1268.   if AObject is THetObjectList then with AObject as THetObjectList do begin
  1269.     for I:=0 to FItems.FCount-1 do
  1270.       WriteObjectDfm(FItems.FItems[i],IO);
  1271.   end;
  1272.   IO.WriteIndentDec;
  1273.   IO.WriteLine('end');
  1274. end;
  1275.  
  1276. procedure ReadObjectPropertiesBin(const AObject:THetObject;const IO:TIO);
  1277.  
  1278.   procedure ReadPropBin(const PropInfo:PPropInfo);
  1279.   var
  1280.     _ansistring:AnsiString;
  1281.     _int:integer;
  1282.     _single:Single;
  1283.     _double:Double;
  1284.     _extended:Extended;
  1285.     _comp:Comp;
  1286.     _curr:Currency;
  1287.     _int64:int64;
  1288.     obj:THetObject;
  1289.     linkCD:TClassDescription;
  1290.     lookupList:THetObjectList;
  1291.   begin with PropInfo^ do begin
  1292.     case PropType^.Kind of
  1293.       tkInteger, tkChar, tkEnumeration, tkSet, tkWChar:begin
  1294.         _int:=0;
  1295.         case GetTypeData(PropType^).OrdType of
  1296.           otSByte,otUByte:IO.IOBlock(_int,1);
  1297.           otSWord,otUWord:IO.IOBlock(_int,2);
  1298.           otSLong,otULong:IO.IOBlock(_int,4);
  1299.         end;
  1300.         SetOrdProp(AObject,PropInfo,_int);
  1301.       end;
  1302.       tkInt64:begin IO.IOBlock(_int64,8);SetInt64Prop(AObject,PropInfo,_int64);end;
  1303.       tkFloat:case GetTypeData(PropType^).FloatType of
  1304.         ftSingle:  begin IO.IOBlock(_single  ,sizeof(_single  ));SetFloatProp(AObject,PropInfo,_single  );end;
  1305.         ftDouble:  begin IO.IOBlock(_Double  ,sizeof(_Double  ));SetFloatProp(AObject,PropInfo,_Double  );end;
  1306.         ftExtended:begin IO.IOBlock(_Extended,sizeof(_Extended));SetFloatProp(AObject,PropInfo,_Extended);end;
  1307.         ftComp:    begin IO.IOBlock(_Comp    ,sizeof(_Comp    ));SetFloatProp(AObject,PropInfo,_Comp    );end;
  1308.         ftCurr:    begin IO.IOBlock(_Curr    ,sizeof(_Curr    ));SetFloatProp(AObject,PropInfo,_Curr    );end;
  1309.       end;
  1310.       tkLString,tkWString,tkUString:begin
  1311.         IO.IO(_ansistring);
  1312.         SetAnsiStrProp(AObject,PropInfo,_ansistring);
  1313.       end;
  1314.       tkClass:begin
  1315.         obj:=THetObject(pointer(cardinal(AObject)+cardinal(GetProc)and $FFFFFF)^);
  1316.         if SetProc=nil then begin//subobj
  1317.           ReadObjectPropertiesBin(obj,IO);
  1318.         end else begin//link
  1319.           linkCD:=ClassDescriptionCache.GetByTypeInfo(GetTypeData(PropType^).ClassType.ClassInfo);
  1320.           if linkCD.IdProp<>nil then begin//by id
  1321.             IO.IOComprCardinal(cardinal(_int));
  1322.             if _int>0 then begin
  1323.               lookupList:=AObject.getLookupList(PropInfo);
  1324.               Assert(lookuplist<>nil,'ReadPropBin() can''t get lookuplist');
  1325.               obj:=lookupList.GetHetObjById(_int-1);
  1326.             end else
  1327.               obj:=nil;
  1328.             SetOrdProp(AObject,PropInfo,integer(obj));
  1329.           end else if linkCD.NameProp<>nil then begin//by name
  1330.             IO.IO(_ansistring);
  1331.             if _ansistring<>'' then begin
  1332.               lookupList:=AObject.getLookupList(PropInfo);
  1333.               Assert(lookuplist<>nil,'ReadPropBin() can''t get lookuplist');
  1334.               obj:=lookupList.GetHetObjByName(_ansistring);
  1335.             end else
  1336.               obj:=nil;
  1337.             SetOrdProp(AObject,PropInfo,integer(obj));
  1338.           end else begin//by index
  1339.             IO.IOComprCardinal(cardinal(_int));
  1340.             if _int>0 then begin
  1341.               lookupList:=AObject.getLookupList(PropInfo);
  1342.               Assert(lookuplist<>nil,'ReadPropBin() can''t get lookuplist');
  1343.               obj:=lookupList.GetHetObjByIndex(_int-1);
  1344.             end else
  1345.               obj:=nil;
  1346.             SetOrdProp(AObject,PropInfo,integer(obj));
  1347.           end;
  1348.         end;
  1349.       end;
  1350.     end;
  1351.   end;end;
  1352.  
  1353. var CD:TClassDescription;
  1354.     i:Integer;
  1355.     actProp:PPropInfo;
  1356.     Hash:integer;
  1357.     needChanged:boolean;
  1358.     list:THetObjectList;
  1359.     cnt:Cardinal;
  1360.  
  1361. begin
  1362.   IO.IOBlock(Hash,4);
  1363.   if(AObject=nil)and(Hash<>0)then raise Exception.Create('ReadObjectBin() AObject is nil, but hash<>0');
  1364.   if AObject=nil then exit;
  1365.   if Hash=0 then raise Exception.Create('ReadObjectBin() AObject is not nil, but hash=0');
  1366.   CD:=ClassDescriptionCache.GetByTypeInfo(AObject.ClassInfo);
  1367.   if CD.Hash<>Hash then raise Exception.Create('ReadObjectBin() Classtype missmatch');
  1368.  
  1369.   needChanged:=false;
  1370.   with CD do for i:=0 to high(PackedStoredRawFields)do with PackedStoredRawFields[i]do if storedId<0 then begin//packed stored
  1371.     IO.IOBlock(pointer(cardinal(AObject)+cardinal(ofs))^,size);
  1372.     needChanged:=true;
  1373.   end else begin
  1374.     actProp:=Storeds[storedId];
  1375.     with actProp^do begin
  1376.       if(cardinal(StoredProc)=1)or IsStoredProp(AObject,actProp)then begin
  1377.         if StoredRawFieldSizes[storedId]>0 then begin//field es raw
  1378.           IO.IOBlock(pointer(cardinal(AObject)+(cardinal(GetProc)and $FFFFFF))^,StoredRawFieldSizes[storedId]);
  1379.           needChanged:=true;
  1380.         end else begin//method vagy nem_raw
  1381.           ReadPropBin(actProp);
  1382.         end;
  1383.       end;
  1384.     end;
  1385.   end;
  1386.   if needChanged then
  1387.     AObject.NotifyChange;
  1388.  
  1389.   if AObject is THetObjectList then begin
  1390.     list:=AObject as THetObjectList;
  1391.     list.clear;
  1392.     IO.IOComprCardinal(cnt);
  1393.     setlength(list.FItems.FItems,cnt);
  1394.     for i:=0 to cnt-1 do
  1395.       ReadHetObject(list,IO);
  1396.   end;
  1397. end;
  1398.  
  1399. function ReadThing(const IO:TIO):ansistring;
  1400.   function PeekChar:AnsiChar;
  1401.   begin
  1402.     if IO.EOF then result:=#0
  1403.               else IO.IOPeek(result,1);
  1404.   end;
  1405.  
  1406.   procedure SkipChar;
  1407.   begin
  1408.     IO.IOSeek(IO.IOPos+1);
  1409.   end;
  1410.  
  1411.   function GetChar:ansichar;
  1412.   begin
  1413.     result:=PeekChar;
  1414.     SkipChar;
  1415.   end;
  1416.  
  1417.   procedure SkipWhiteSpace;
  1418.   begin
  1419.     while PeekChar in [#10,#13,#9,' ']do SkipChar;
  1420.   end;
  1421.  
  1422. label re;
  1423. begin
  1424.   result:='';
  1425.   SkipWhiteSpace;
  1426.  
  1427.   case PeekChar of
  1428.     #0:exit;
  1429.     'a'..'z','A'..'Z','_':begin
  1430.       while PeekChar in['a'..'z','A'..'Z','_','0'..'9','.']do
  1431.         result:=result+GetChar;
  1432.     end;
  1433.     '''','#':begin
  1434.       re:
  1435.       while PeekChar='''' do begin
  1436.         result:=result+GetChar;
  1437.         while not(PeekChar in[#0,''''])do
  1438.           result:=result+GetChar;
  1439.         result:=result+GetChar;
  1440.       end;
  1441.       if PeekChar='#' then begin
  1442.         result:=result+GetChar;
  1443.         while PeekChar in['$','0'..'9']do
  1444.           result:=result+GetChar;
  1445.         goto re;
  1446.       end;
  1447.     end;
  1448.     '+','-','0'..'9':while PeekChar in['+','-','0'..'9','.','e','E']do Result:=Result+GetChar;
  1449.   else result:=GetChar;end;
  1450.  
  1451.   SkipWhiteSpace;
  1452. end;
  1453.  
  1454. function PasToVar(const s:ansistring):Variant;
  1455. var ch:PAnsiChar;
  1456. begin
  1457.   if s='' then exit(Unassigned);
  1458.  
  1459.   if s[1]in['''','#']then begin
  1460.     {replace('''''','''',s,[roAll]);
  1461.     s:=copy(s,2,length(s)-2);
  1462.     result:=s;}
  1463.     ch:=pointer(s);
  1464.     result:=AnsiString(ParsePascalConstant(ch));
  1465.   end else begin
  1466.     if pos('.',s)>0 then result:=StrToFloatDef(s,0)
  1467.                     else Result:=StrToIntDef(s,0);
  1468.   end;
  1469. end;
  1470.  
  1471. procedure ReadObjectPropertiesDfm(const AObject:THetObject;const IO:TIO);
  1472.  
  1473. var CD:TClassDescription;
  1474.     i:Integer;
  1475.     actProp:PPropInfo;
  1476.     CName:ansistring;
  1477.     list:THetObjectList;
  1478.     s,s2:ansistring;
  1479.     oldPos,posStart:integer;
  1480.     obj:THetObject;
  1481.     linkCD:TClassDescription;
  1482.     _int:integer;
  1483.     _ansistring:ansistring;
  1484.     lookupList:THetObjectList;
  1485. begin
  1486.   if cmp(ReadThing(IO),'object')=0 then CName:=ReadThing(IO)
  1487.                                    else begin CName:='';raise exception.Create('fakk');end;
  1488.  
  1489.   //ez suxx, nem megy nil-re
  1490.   if(AObject=nil)and(CName<>'')then raise Exception.Create('ReadObjectDfm() AObject is nil, but CName<>""');
  1491.   if AObject=nil then exit;
  1492.   if CName='' then raise Exception.Create('ReadObjectDfm() AObject is not nil, but CName=""'+inttostr(IO.IOPos));
  1493.   CD:=ClassDescriptionCache.GetByTypeInfo(AObject.ClassInfo);
  1494.   if CD.Hash<>Crc32UC(CName)then raise Exception.Create('ReadObjectDfm() Classtype missmatch');
  1495.  
  1496.   if AObject is THetObjectList then begin
  1497.     list:=AObject as THetObjectList;
  1498.     list.clear;
  1499.   end else
  1500.     list:=nil;
  1501.  
  1502.   while not IO.EOF do begin
  1503.     posStart:=IO.IOPos;
  1504.     s:=readThing(IO);
  1505.  
  1506.     if cmp(s,'object')=0 then begin
  1507.       if list=nil then raise Exception.Create('ReadObjectDfm() object found, but Self is not THetObjectList');
  1508.       IO.IOSeek(posStart);
  1509.       ReadHetObject(list,IO);
  1510.     end else if Cmp(s,'end')=0 then begin
  1511.       break;
  1512.     end else begin
  1513.       //field
  1514.       if ReadThing(IO)<>'=' then raise Exception.Create('ReadObjectDfm() "=" expected ('+AObject.ClassName+'.'+s+' at '+tostr(io.iopos)+')'+AObject.getName);
  1515.       oldpos:=IO.IOPos;
  1516.       s2:=ReadThing(IO);
  1517.  
  1518.       with CD do for i:=0 to High(Storeds)do if cmp(storeds[i].Name,s)=0 then begin
  1519.         actProp:=Storeds[i];
  1520.         with actProp^do
  1521.           if(cardinal(StoredProc)=1)or IsStoredProp(AObject,actProp)then begin
  1522.             if actProp.PropType^.Kind=tkClass then begin
  1523.               obj:=THetObject(pointer(cardinal(AObject)+cardinal(GetProc)and $FFFFFF)^);
  1524.               if SetProc=nil then begin//subobj
  1525.                 IO.IOSeek(oldPos);
  1526.                 ReadObjectPropertiesDfm(obj,IO);
  1527.               end else begin//link
  1528.                 linkCD:=ClassDescriptionCache.GetByTypeInfo(GetTypeData(PropType^).ClassType.ClassInfo);
  1529.                 if linkCD.IdProp<>nil then begin//by id
  1530.                   _int:=PasToVar(s2);
  1531.                   if _int>0 then begin
  1532.                     lookupList:=AObject.getLookupList(actProp);
  1533.                     Assert(lookuplist<>nil,'ReadPropBin() can''t get lookuplist');
  1534.                     obj:=lookupList.GetHetObjById(_int{-1});
  1535. {                    if obj=nil then
  1536.                       raise Exception.Create(lookupList.ClassName+'.gethetobjbyid('+tostr(_int-1)+' fail');}
  1537.                   end else
  1538.                     obj:=nil;
  1539.                   SetOrdProp(AObject,actProp,integer(obj));
  1540.                 end else if linkCD.NameProp<>nil then begin//by name
  1541.                   _ansistring:=PasToVar(s2);
  1542.                   if _ansistring<>'' then begin
  1543.                     lookupList:=AObject.getLookupList(actProp);
  1544.                     Assert(lookuplist<>nil,'ReadPropBin() can''t get lookuplist');
  1545.                     obj:=lookupList.GetHetObjByName(_ansistring);
  1546.                   end else
  1547.                     obj:=nil;
  1548.                   SetOrdProp(AObject,actProp,integer(obj));
  1549.                 end else begin//by index
  1550.                   _int:=PasToVar(s2);
  1551.                   if _int>0 then begin
  1552.                     lookupList:=AObject.getLookupList(actProp);
  1553.                     Assert(lookuplist<>nil,'ReadPropBin() can''t get lookuplist');
  1554.                     obj:=lookupList.GetHetObjByIndex(_int-1);
  1555.                   end else
  1556.                     obj:=nil;
  1557.                   SetOrdProp(AObject,actProp,integer(obj));
  1558.                 end;
  1559.               end;
  1560.  
  1561.             end else begin
  1562.               if(actProp=CD.IdProp)then
  1563.                 AObject._SetID(PasToVar(s2))
  1564.               else begin
  1565.                 if actProp.PropType^.Kind=tkInt64 then
  1566.                   SetPropValue(AObject,actProp,StrToInt64(s2))
  1567.                 else
  1568.                   SetPropValue(AObject,actProp,PasToVar(s2));
  1569.               end;
  1570.             end;
  1571.           end;
  1572.       end;
  1573.  
  1574.     end;
  1575.   end;
  1576.  
  1577.   AObject.NotifyChange;
  1578.  
  1579. end;
  1580.  
  1581. function DetectDFM(const hash:integer):boolean;
  1582. var ch:array[0..3]of ansichar absolute hash;
  1583. begin
  1584.   Result:=cmp(ch,'obje')=0;
  1585. end;
  1586.  
  1587. procedure ReadObjectProperties(const AObject:THetObject;const IO:TIO);
  1588. var i:integer;
  1589. begin
  1590.   i:=0;IO.IOPeek(i,4);
  1591.   if DetectDFM(i)then ReadObjectPropertiesDfm(AObject,IO)
  1592.                  else ReadObjectPropertiesBin(AObject,IO);
  1593. end;
  1594.  
  1595. function ReadHetObject(const AOwner:THetObject;const IO:TIO):THetObject;
  1596. var Hash:integer;
  1597.     i:integer;
  1598.     CD:TClassDescription;
  1599. begin
  1600.   i:=IO.IOPos;
  1601.   IO.IOPeek(Hash,4);
  1602.   if Hash=0 then exit(nil);
  1603.  
  1604.   if DetectDFM(Hash)then begin
  1605.     IO.IOSeek(i);
  1606.     ReadThing(IO);
  1607.     Hash:=Crc32UC(ReadThing(IO));
  1608.     IO.IOSeek(i);
  1609.   end;
  1610.  
  1611.   CD:=ClassDescriptionOf(Hash);
  1612.   result:=THetObjectClass(GetTypeData(CD.TypeInfo).ClassType).Create(AOwner);
  1613.   result.Serialize(IO,stBin);
  1614. end;
  1615.  
  1616. { THetObject }
  1617.  
  1618. {var _Root:THetObjectList=nil;
  1619.     CreatingRoot:boolean=false;
  1620. function Root:THetObjectList;
  1621. begin
  1622.   if _Root=nil then begin
  1623.     CreatingRoot:=true;
  1624.     _Root:=THetObjectList.Create(nil);
  1625.     CreatingRoot:=false;
  1626.   end;
  1627.   result:=_Root;
  1628. end;}
  1629.  
  1630. constructor THetObject.Create(const AOwner:THetObject);
  1631. begin
  1632.   if AOwner<>nil then
  1633.     FOwner:=AOwner
  1634.   else
  1635. {    if CreatingRoot then
  1636.       FOwner:=nil
  1637.     else}
  1638.       FOwner:=Root;
  1639.  
  1640.   if(FOwner is THetObjectList)and(stListActive in THetObjectList(FOwner).ObjState)then
  1641.     THetObjectList(FOwner)._AppendListObj(self);
  1642.  
  1643.   NotifyCreate;
  1644.  
  1645.   with ClassDesc do begin
  1646.     SetDefaults(self);
  1647.     CreateSubObjs(self);
  1648.   end;
  1649.  
  1650.   AfterCreate;
  1651. end;
  1652.  
  1653. destructor THetObject.Destroy;
  1654. var i:integer;
  1655. begin
  1656.   NotifyDestroy;
  1657.   with FReferences do for i:=0 to FCount-1 do FItems[i]._LinkedObjDestroying(self);FReferences.FCount:=0;
  1658.   if Assigned(FOwner)then FOwner._SubObjDestroying(self);
  1659.   with ClassDesc do begin
  1660.     ClearLinkedObjs(self);
  1661.     FreeSubObjs(self);
  1662.   end;
  1663. end;
  1664.  
  1665. procedure THetObject.AfterCreate;
  1666. begin
  1667. end;
  1668.  
  1669. procedure THetObject.Serialize(const st: TIO;const SerType:TSerializeType);
  1670. begin
  1671.   if st.IOWriting then begin
  1672.     case SerType of
  1673.       stBin:WriteObjectBin(self,st);
  1674.       stDfm:WriteObjectDfm(self,st);
  1675.     end;
  1676.   end else
  1677.     ReadObjectProperties(self,st);
  1678. end;
  1679.  
  1680. function THetObject.dump(const AIndent: integer):ansistring;
  1681.  
  1682.   function DumpOne(o:THetObject):ansistring;
  1683.     function GetNameOrPtr:ansistring;
  1684.     begin result:=o.getName;if result='' then result:='$'+inttohex(integer(o),8);end;
  1685.   begin
  1686.     if o=nil then result:=result+'nil'
  1687.              else result:='('+getNameOrPtr+':'+o.ClassName+')';
  1688.   end;
  1689.  
  1690. begin
  1691.   result:=DumpOne(self);
  1692.   if self<>nil then begin
  1693.     result:=result+' Owner='+DumpOne(FOwner);
  1694.     if FOwner<>nil then
  1695.       result:=result+'.Owner='+DumpOne(FOwner.FOwner);
  1696.   end;
  1697.  
  1698.   result:=Indent('  ',AIndent)+result+#13#10;
  1699. end;
  1700.  
  1701. function THetObject.getId: TId;
  1702. begin
  1703.   if self=nil then exit(0);//nil safe
  1704.   with ClassDesc do begin
  1705.     if IdProp<>nil then result:=pinteger(cardinal(self)+cardinal(IdProp.GetProc)and $FFFFFF)^
  1706.                    else result:=0;
  1707.   end;
  1708. end;
  1709.  
  1710. procedure THetObject.setId(const aId:TId);
  1711. var p:PInteger;
  1712. begin with ClassDesc do begin
  1713.   if IdProp<>nil then begin
  1714.     p:=pinteger(cardinal(self)+cardinal(IdProp.GetProc)and $FFFFFF);
  1715.     if p^<>aId then begin
  1716.       p^:=aId;
  1717.       NotifyChange;
  1718.     end;
  1719.   end;
  1720. end;end;
  1721.  
  1722. procedure THetObject.SetName(const AName: TName);
  1723. var p:PAnsiString;
  1724. begin with ClassDesc do begin
  1725.   if NameProp<>nil then begin
  1726.     p:=pAnsiString(cardinal(self)+cardinal(NameProp.GetProc)and $FFFFFF);
  1727.     if p^<>AName then begin
  1728.       p^:=AName;
  1729.       NotifyChange;
  1730.     end;
  1731.   end;
  1732. end;end;
  1733.  
  1734. function THetObject.getIndex: integer;
  1735. begin
  1736.   if self=nil then exit(-1);//nil safe
  1737.   if FOwner is THetObjectList then result:=THetObjectList(FOwner).IndexOf(self)
  1738.                               else result:=-1;
  1739. end;
  1740.  
  1741. procedure THetObject.setIndex(const newIdx:integer);
  1742. var oldIdx:integer;
  1743. begin
  1744.   if FOwner is THetObjectList then begin
  1745.     oldIdx:=THetObjectList(FOwner).IndexOf(self);
  1746.     if(oldIdx>=0)then
  1747.       THetObjectList(FOwner).Move(oldIdx,newIdx);
  1748.   end;
  1749. end;
  1750.  
  1751. function THetObject.SubObjName: AnsiString;
  1752. var i:integer;
  1753. begin
  1754.   result:='';
  1755.   if FOwner=nil then exit;
  1756.   with FOwner.ClassDesc do
  1757.     for i:=0 to high(SubObjects)do
  1758.       if GetOrdProp(FOwner,SubObjects[i])=integer(self) then
  1759.         exit(Subobjects[i].Name);
  1760. end;
  1761.  
  1762. function THetObject.getFieldAsVariant(const AFieldName: ansistring): Variant;
  1763. const types=[tkInteger,tkInt64,tkChar,tkEnumeration,tkSet,tkFloat,tkString,tkLString,tkUString,tkWString];
  1764. var cd:TClassDescription;
  1765.     pi:PPropInfo;
  1766. begin
  1767.   cd:=ClassDesc;
  1768.   pi:=cd.PropInfoByName(AFieldName);
  1769.   if(pi<>nil)and(pi.GetProc<>nil)and(pi.PropType^.Kind in Types)then
  1770.     Result:=GetPropValue(self,pi,false)
  1771.   else
  1772.     Result:=Unassigned;
  1773. end;
  1774.  
  1775. procedure THetObject.setFieldAsVariant(const AFieldName: ansistring; const Value: Variant);
  1776. const types=[tkInteger,tkInt64,tkChar,tkEnumeration,tkSet,tkFloat,tkString,tkLString,tkUString,tkWString];
  1777. var cd:TClassDescription;
  1778.     pi:PPropInfo;
  1779. begin
  1780.   cd:=ClassDesc;
  1781.   pi:=cd.PropInfoByName(AFieldName);
  1782.   if(pi<>nil)and(pi.SetProc<>nil)and(pi.PropType^.Kind in types)then
  1783.     SetPropValue(self,pi,Value);
  1784.   //!!!!!!!!!!!Classra figyelni majd
  1785. end;
  1786.  
  1787. function THetObject.getLookupList(const PropInfo: PPropInfo): THetObjectList;
  1788. begin
  1789.   raise Exception.Create('Unable to get LookupList for '+ClassName+'.'+PropInfo.Name);
  1790. end;
  1791.  
  1792. function THetObject.getName: TName;
  1793. begin
  1794.   if self=nil then exit('');//nil safe
  1795.   with ClassDesc do begin
  1796.     if NameProp<>nil then result:=GetStrProp(self,NameProp)
  1797.                      else result:='';
  1798.   end;
  1799. end;
  1800.  
  1801. function THetObject.IsNil: boolean;
  1802. begin
  1803.   result:=Self=nil;
  1804. end;
  1805.  
  1806. class function THetObject.ClassDesc: TClassDescription;
  1807. begin
  1808.   result:=ClassDescriptionCache.GetByTypeInfo(ClassInfo);
  1809. end;
  1810.  
  1811. procedure THetObject.NotifyChange;
  1812. begin
  1813.   ObjState:=ObjState+[stChangedSave];
  1814.   ChangeEventDispatcher(self,ctChange);
  1815. end;
  1816.  
  1817. procedure THetObject.NotifyCreate;
  1818. begin
  1819.   ChangeEventDispatcher(self,ctCreate);
  1820. end;
  1821.  
  1822. procedure THetObject.NotifyDestroy;
  1823. begin
  1824.   ChangeEventDispatcher(self,ctDestroy);
  1825. end;
  1826.  
  1827. procedure THetObject.ChangeEventDispatcher(const AObj:THetObject;const AChangeType:TChangeType);
  1828. var i:integer;
  1829. begin
  1830.   ObjState:=ObjState+stChangedAll;
  1831.   ObjectChanged(AObj,AChangeType);
  1832.   if Assigned(FOwner)then FOwner.ChangeEventDispatcher(AObj,AChangeType);
  1833.   with FReferences do for i:=0 to FCount-1 do FItems[i].ChangeEventDispatcher(AObj,AChangeType);//rekurziv szivas
  1834. end;
  1835.  
  1836. procedure THetObject.ObjectChanged;
  1837. begin
  1838. end;
  1839.  
  1840. procedure THetObject._AddReference(const AObj:THetObject);
  1841. begin
  1842.   FReferences.Append(AObj);
  1843. end;
  1844.  
  1845. procedure THetObject._RemoveReference(const AObj:THetObject);
  1846. var i:integer;
  1847. begin
  1848.   for i:=FReferences.FCount-1 downto 0 do
  1849.     if FReferences.FItems[i]=AObj then begin
  1850.       FReferences.Remove(i);
  1851.       exit;
  1852.     end;
  1853. end;
  1854.  
  1855. procedure THetObject._SetID(const AID: integer);
  1856. var pi:PPropInfo;
  1857. begin
  1858.   pi:=ClassDesc.IdProp;
  1859.   if pi<>nil then begin
  1860.     pinteger(integer(self)+(integer(pi.GetProc)and $FFFFFF))^:=AID;
  1861. //    NotifyChange;
  1862.   end;
  1863. end;
  1864.  
  1865. procedure THetObject._SubObjDestroying(const AObj:THetObject);
  1866. {var i:integer;
  1867.     p:ppointer;}
  1868. begin
  1869.   {semmi, mert subobjokat nem destroyozunk}
  1870. {  with ClassDesc do begin
  1871.     for i:=0 to high(SubObjects)do with SubObjects[i]^ do begin
  1872.       p:=pointer(cardinal(self)+cardinal(GetProc)and $FFFFFF);
  1873.       if p^=AObj then begin
  1874.         p^:=nil;
  1875.         NotifyChange;
  1876.         exit;
  1877.       end;
  1878.     end;
  1879.     Assert(false,'Subobject not found');
  1880.   end;}
  1881. end;
  1882.  
  1883. procedure THetObject._LinkedObjDestroying(const AObj:THetObject);
  1884. var i:integer;
  1885.     p:ppointer;
  1886. begin
  1887.   with ClassDesc do begin
  1888.     for i:=0 to high(LinkedObjects)do with LinkedObjects[i]^ do begin
  1889.       p:=pointer(cardinal(self)+cardinal(GetProc)and $FFFFFF);
  1890.       if p^=AObj then begin
  1891.         p^:=nil;
  1892.         NotifyChange;
  1893.       end;
  1894.     end;
  1895.   end;
  1896. end;
  1897.  
  1898. procedure THetObject.Reset;
  1899. begin
  1900.   ClassDesc.Reset(self);
  1901. end;
  1902.  
  1903. procedure THetObject.LoadFromStr(const Data:RawByteString);
  1904. var st:TIO;
  1905. begin
  1906.   if pointer(Data)=nil then begin
  1907.     Reset;
  1908.     exit
  1909.   end;
  1910.   st:=TIOBinReader.Create;
  1911.   st.Data:=Data;
  1912.   try
  1913.     Serialize(st,stBin);
  1914.   finally
  1915.     st.Free;
  1916.   end;
  1917. end;
  1918.  
  1919. function THetObject.SaveToStr;
  1920. var st:TIO;
  1921. begin
  1922.   setlength(result,0);
  1923.   st:=TIOBinWriter.Create;
  1924.   try
  1925.     Serialize(st,serType);
  1926.     result:=st.Data;
  1927.   finally
  1928.     st.Free;
  1929.   end;
  1930. end;
  1931.  
  1932. function THetObject.TryLoadFromFile(const FN:string):boolean;
  1933. var data:RawByteString;
  1934. begin
  1935.   data:=TFile(FN);
  1936.   if Data='' then exit(false);
  1937.   LoadFromStr(data);
  1938.   result:=true;
  1939. end;
  1940.  
  1941. procedure THetObject.LoadFromFile(const FN:string);
  1942. var data:RawByteString;
  1943. begin
  1944.   data:=TFile(fn);
  1945.   if data='' then raise Exception.Create(ClassName+'.LoadFromFile() File not found or empty "'+FN+'"');
  1946.   LoadFromStr(data);
  1947. end;
  1948.  
  1949. procedure THetObject.SaveToFile(const serType:TSerializeType;const FN:string);
  1950. begin
  1951.   TFile(FN).Write(SaveToStr(serType));
  1952. end;
  1953.  
  1954. { THetObjectViewSettings }
  1955.  
  1956. destructor THetObjectViewSettings.Destroy;
  1957. begin
  1958.   Reset;
  1959.   inherited;
  1960. end;
  1961.  
  1962. procedure THetObjectViewSettings.Reset;
  1963. var i:integer;
  1964. begin
  1965.   for i:=0 to high(FOrderBy)do FOrderBy[i].Node.Free;
  1966.   setlength(FOrderBy,0);
  1967.  
  1968.   for i:=0 to high(FWhereAnd)do FWhereAnd[i].Node.Free;
  1969.   setlength(FWhereAnd,0);
  1970.  
  1971.   FreeAndNil(FNameSpace);
  1972.   FreeAndNil(FCtx);
  1973. end;
  1974.  
  1975. procedure THetObjectViewSettings.SetDefinition;
  1976.  
  1977.   procedure AddOrderBy(s:ansistring);
  1978.   var n:TNodeBase;
  1979.       d:boolean;
  1980.   begin
  1981.     d:=charn(s,1)='-';
  1982.     if d then delete(s,1,1);
  1983.     n:=CompilePascalStatement(s,TNameSpace(FNameSpace));
  1984.     if n<>nil then begin
  1985.       SetLength(FOrderBy,length(FOrderBy)+1);
  1986.       with FOrderBy[high(FOrderBy)]do begin
  1987.         node:=n;
  1988.         desc:=switch(d,-1,1);
  1989.       end;
  1990.     end;
  1991.   end;
  1992.  
  1993.   procedure AddWhereAnd(const s:ansistring);
  1994.   var n:TNodeBase;
  1995.   begin
  1996.     n:=CompilePascalStatement(s,TNameSpace(FNameSpace));
  1997.     if n<>nil then begin
  1998.       SetLength(FWhereAnd,length(FWhereAnd)+1);
  1999.       with FWhereAnd[high(FWhereAnd)]do begin
  2000.         node:=n;
  2001.       end;
  2002.     end;
  2003.   end;
  2004.  
  2005. var sOrder,s:ansistring;
  2006.     i:integer;
  2007. begin
  2008.   if Value<>FDefinition then begin
  2009.     Reset;
  2010.  
  2011.     FDefinition:=Value;
  2012.     FHash:=Crc32UC(FDefinition);
  2013.     if FUnique then FHash:=FHash xor integer(self);
  2014.  
  2015.     try
  2016.       FNameSpace:=TNameSpace.Create('nsHetObjectComparer');
  2017.       FNameSpace.nsUses.Append(nsSystem);
  2018.       FCtx:=TContext.Create(nil,FNameSpace,nil);
  2019.       FCtx.WithStack.Append(nil);
  2020.  
  2021.       sOrder:=ListItem(FDefinition,0,'|');
  2022.       for s in ListSplit(sOrder,',')do
  2023.         AddOrderBy(s);
  2024.  
  2025.       for i:=1 to ListCount(FDefinition,'|')-1 do
  2026.         AddWhereAnd(ListItem(FDefinition,i,'|'));
  2027.  
  2028.     except
  2029.       Reset;
  2030.     end;
  2031.  
  2032.   end;
  2033. end;
  2034.  
  2035. function THetObjectViewSettings.Compare(const a,b:THetObject):integer;
  2036. var i:integer;
  2037.     va,vb:Variant;
  2038. begin
  2039.   for i:=0 to high(FOrderBy)do with FOrderBy[i]do begin
  2040.  
  2041.     FCtx.WithStack.FItems[0]:=a;
  2042.     node.Eval(FCtx,va);
  2043.  
  2044.     FCtx.WithStack.FItems[0]:=b;
  2045.     node.Eval(FCtx,vb);
  2046.  
  2047.     if va<vb then exit(-desc);
  2048.     if va>vb then exit(desc);
  2049.   end;
  2050.   result:=0;
  2051. end;
  2052.  
  2053. function THetObjectViewSettings.Filter(const a:THetObject):boolean;
  2054. var i:integer;
  2055.     b:boolean;
  2056. begin
  2057.   b:=false;//anti warning
  2058.   result:=true;
  2059.   if length(FWhereAnd)>0 then begin
  2060.     Assert(FCtx.WithStack.Count=1,'THetObjectViewSettings.Filter ctx.withstack.count<>1');
  2061.     FCtx.WithStack.FItems[0]:=a;
  2062.     for i:=0 to high(FWhereAnd)do with FWhereAnd[i]do
  2063.       try b:=node.Eval(FCtx)except b:=false end;//!!!!!!!!!!!!!!!ez a try except ide elvileg nem kell
  2064.       if not b then exit(false);
  2065.   end;
  2066. end;
  2067.  
  2068. function THetObjectViewSettings.FindValues(const a:THetObject):integer;
  2069. var i,k:integer;
  2070.     va:PVariant;
  2071.     vb:Variant;
  2072. begin
  2073.   k:=high(FValueStack);
  2074.   for i:=0 to max(high(FOrderBy),high(FValueStack[k]))do with FOrderBy[i]do begin
  2075.  
  2076.     FCtx.WithStack.FItems[0]:=a;
  2077.     node.Eval(FCtx,vb);
  2078.  
  2079.     va:=@FValueStack[k,i];
  2080.  
  2081.     if va^<vb then exit(-desc);
  2082.     if va^>vb then exit(desc);
  2083.   end;
  2084.   result:=0;
  2085. end;
  2086.  
  2087. procedure THetObjectViewSettings.PopValues;
  2088. begin
  2089.   setlength(FValueStack,high(FValueStack));
  2090. end;
  2091.  
  2092. procedure THetObjectViewSettings.PushValues(const values: array of const);
  2093. var i,k:integer;
  2094. begin
  2095.   setlength(FValueStack,Length(FValueStack)+1);
  2096.   k:=high(FValueStack);
  2097.   setlength(FValueStack[k],length(values));
  2098.   for i:=0 to high(values)do with values[i]do case VType of
  2099.     vtInteger       :FValueStack[k,i]:=VInteger;
  2100.     vtBoolean       :FValueStack[k,i]:=VBoolean;
  2101.     vtChar          :FValueStack[k,i]:=VChar;
  2102.     vtExtended      :FValueStack[k,i]:=VExtended^;
  2103.     vtString        :FValueStack[k,i]:=VString^;
  2104.     vtPointer       :{FValueStack[k,i]:=                 Unassigned};
  2105.     vtPChar         :FValueStack[k,i]:=VPChar^;
  2106.     vtObject        :FValueStack[k,i]:=het.Variants.VObject(VObject);
  2107.     vtClass         :FValueStack[k,i]:=het.Variants.VClass(VClass);
  2108.     vtWideChar      :FValueStack[k,i]:=VWideChar;
  2109.     vtPWideChar     :FValueStack[k,i]:=VPWideChar^;
  2110.     vtAnsiString    :FValueStack[k,i]:=AnsiString(VAnsiString);
  2111.     vtCurrency      :FValueStack[k,i]:=VCurrency^;
  2112.     vtVariant       :FValueStack[k,i]:=VVariant^;
  2113.     vtInterface     :FValueStack[k,i]:=IInterface(VInterface);
  2114.     vtWideString    :FValueStack[k,i]:=WideString(VWideString);
  2115.     vtInt64         :FValueStack[k,i]:=VInt64^;
  2116.     vtUnicodeString :FValueStack[k,i]:=UnicodeString(VUnicodeString);
  2117.   end;
  2118. end;
  2119.  
  2120. { THetObjectList }
  2121.  
  2122. function THetObjectList.GetHetObjById(const AId: integer): THetObject;
  2123. var idx:integer;
  2124. begin
  2125.   //binary search baszki?!!!
  2126. //  {slow search}with FItems do for i:=0 to FCount-1 do if FItems[i].getId=AId then exit(FItems[i]);
  2127.   with View['id']do
  2128.     if FItems.FindBinary(function(const a:THetObject):integer begin result:=AId-a.getId end,idx)then
  2129.       exit(FItems.FItems[idx]);
  2130.   result:=nil;
  2131. end;
  2132.  
  2133. function THetObjectList.GetHetObjByIndex(const AIdx: integer): THetObject;
  2134. begin
  2135.   with FItems do if AIdx<FCount then result:=FItems[AIdx]
  2136.                                 else result:=nil;
  2137. end;
  2138.  
  2139. function THetObjectList.GetHetObjByName(const AName: ansistring): THetObject;
  2140. var idx:integer;
  2141. begin
  2142.   with View['name']do
  2143.     if FItems.FindBinary(function(const a:THetObject):integer begin result:=cmp(AName,a.getName)end,idx)then
  2144.       exit(FItems.FItems[idx]);
  2145.   result:=GetByNameCached(AName);//create new
  2146. end;
  2147.  
  2148. function THetObjectList.GetIsView: boolean;
  2149. begin
  2150.   result:=ClassType.ClassParent=THetObjectListView;
  2151. end;
  2152.  
  2153. function THetObjectList.GetIsViewUnique: boolean;
  2154. begin
  2155.   result:=(FViewSettings<>nil)and(FViewSettings.FUnique);
  2156. end;
  2157.  
  2158. function THetObjectList.getNextItemId: integer;
  2159. begin
  2160.   with FItems do if FCount>0 then result:=FItems[FCount-1].getId+1
  2161.                              else result:=1;
  2162. end;
  2163.  
  2164. function THetObjectList.getNextItemNameFor(const AObj:THetObject):ansistring;
  2165. var idx,i,j:integer;
  2166.     n:ansistring;
  2167. begin
  2168.   result:=AObj.ClassName+'1';
  2169.   if charn(result,1)='T' then delete(result,1,1);
  2170.  
  2171.   idx:=FindBinaryIdx('Name',[result]);
  2172.   if idx>=0 then begin
  2173.     setlength(result,length(result)-1);j:=1;
  2174.     for i:=0 to FItems.Count-1 do if FItems.FItems[i]<>self then begin
  2175.       n:=FItems.FItems[i].getName;
  2176.       if cmp(n,result+toStr(j))=0 then inc(j)
  2177.     end;
  2178.     result:=result+toStr(j);
  2179.   end;
  2180. end;
  2181.  
  2182. function THetObjectList.IndexOf(const AObj: THetObject):integer;var i:integer;
  2183. begin
  2184.   with FItems do for i:=0 to FCount-1 do if FItems[i]=AObj then exit(i);
  2185.   result:=-1;
  2186. end;
  2187.  
  2188. procedure THetObjectList.Sort;
  2189. begin
  2190.   if FViewSettings=nil then exit;
  2191.   FItems.QuickSort(FViewSettings.Compare);
  2192.   NotifyChange;
  2193. end;
  2194.  
  2195. procedure THetObjectList.Exchange(const Idx1, Idx2: integer);
  2196. begin
  2197.   FItems.Exchange(Idx1,Idx2);
  2198. end;
  2199.  
  2200. function THetObjectList.FindBinaryIdx(const AFields: ansistring;const AValues:array of const):integer;
  2201. begin
  2202.   result:=-1;
  2203.   with View[AFields]do begin
  2204.     FViewSettings.PushValues(AValues);
  2205.     try
  2206.       if not FItems.FindBinary(FViewSettings.FindValues,result)then result:=-1;
  2207.     finally
  2208.       FViewSettings.PopValues;
  2209.     end;
  2210.   end;
  2211. end;
  2212.  
  2213. function THetObjectList.FindBinary(const AFields: ansistring;const AValues:array of const):THetObject;
  2214. var idx:integer;
  2215. begin
  2216.   result:=nil;
  2217.   with View[AFields]do begin
  2218.     FViewSettings.PushValues(AValues);
  2219.     try
  2220.       if FItems.FindBinary(FViewSettings.FindValues,idx)then result:=FItems.FItems[idx];
  2221.     finally
  2222.       FViewSettings.PopValues;
  2223.     end;
  2224.   end;
  2225. end;
  2226.  
  2227. function THetObjectList.FindBinaryNearestIdx(const AFields: ansistring;const AValues:array of const):integer;
  2228. begin
  2229.   result:=-1;
  2230.   with View[AFields]do begin
  2231.     FViewSettings.PushValues(AValues);
  2232.     try
  2233.       FItems.FindBinary(FViewSettings.FindValues,result);
  2234.     finally
  2235.       FViewSettings.PopValues;
  2236.     end;
  2237.   end;
  2238. end;
  2239.  
  2240. function THetObjectList.FindBinaryIdxRange(const AFields: ansistring;const AValues:array of const):TIdxRange;
  2241. begin
  2242.   with View[AFields]do begin
  2243.     FViewSettings.PushValues(AValues);
  2244.     try
  2245.       if FItems.FindBinary(FViewSettings.FindValues,result.st)then begin
  2246.         result.en:=result.st;
  2247.         while(result.St>0)and(FViewSettings.FindValues(FItems.FItems[result.St-1])=0)do
  2248.           dec(result.St);
  2249.         while(result.En<FItems.FCount-1)and(FViewSettings.FindValues(FItems.FItems[result.En+1])=0)do
  2250.           inc(result.En);
  2251.       end else begin
  2252.         result.St:=0;
  2253.         result.En:=-1;
  2254.       end;
  2255.     finally
  2256.       FViewSettings.PopValues;
  2257.     end;
  2258.   end;
  2259. end;
  2260.  
  2261. function THetObjectList.FindBinaryRange(const AFields: ansistring;const AValues:array of const):TArray<THetObject>;
  2262. var tmp:THetArray<THetObject>;
  2263.     i,st,en:integer;
  2264. begin
  2265.   tmp.Clear;
  2266.  
  2267.   with View[AFields]do begin
  2268.     FViewSettings.PushValues(AValues);
  2269.     try
  2270.       if FItems.FindBinary(FViewSettings.FindValues,st)then begin
  2271.         en:=st;
  2272.         while(St>0)and(FViewSettings.FindValues(FItems.FItems[St-1])=0)do
  2273.           dec(St);
  2274.         while(En<FItems.FCount-1)and(FViewSettings.FindValues(FItems.FItems[En+1])=0)do
  2275.           inc(En);
  2276.       end else begin
  2277.         St:=0;
  2278.         En:=-1;
  2279.       end;
  2280.     finally
  2281.       FViewSettings.PopValues;
  2282.     end;
  2283.  
  2284.     for i:=st to en do
  2285.       tmp.Append(FItems.FItems[i]);
  2286.     tmp.Compact;
  2287.   end;
  2288.   result:=tmp.FItems;
  2289. end;
  2290.  
  2291. procedure THetObjectList.Move(const Idx1, Idx2: integer);
  2292. begin
  2293.   if(Idx1=Idx2)then exit;
  2294.   FItems.Move(Idx1,Idx2);
  2295.   NotifyChange;
  2296. end;
  2297.  
  2298. function THetObjectList.NewUniqueView(const ADef:ansistring): THetObjectListView;
  2299. begin
  2300.   if IsView then exit(ViewBase.NewUniqueView(ADef));
  2301.   if FViews=nil then begin
  2302.     ObjState:=ObjState-[stListActive];
  2303.     FViews:=THetObjectList.Create(self);
  2304.     ObjState:=ObjState+[stListActive];
  2305.     FViews.ViewDefinition:='hash';
  2306.   end;
  2307.  
  2308.   result:=THetObjectListView.Create(FViews);
  2309.   with result do begin
  2310.     FViewSettings:=THetObjectViewSettings.create;
  2311.     FViewSettings.FUnique:=true;
  2312.     FViewSettings.Definition:=ADef;
  2313.     Result.NotifyChange;//sort by hash
  2314.   end;
  2315.   result.RefreshView;
  2316. end;
  2317.  
  2318. procedure THetObjectList.ChangeEventDispatcher(const AObj:THetObject;const AChangeType:TChangeType);
  2319. var i:integer;
  2320. begin
  2321.   inherited;
  2322.  
  2323.   if AObj=FViews then exit;
  2324.  
  2325.   //View-eken is vegigmengy a main.change
  2326.   if FViews<>nil then
  2327.     for i:=0 to FViews.Count-1 do
  2328.       FViews.GetHetObjByIndex(i).ObjectChanged(AObj,AChangeType);
  2329. end;
  2330.  
  2331. procedure THetObjectList.ObjectChanged(const AObj: THetObject;const AChangeType:TChangeType);
  2332. var i,idx:integer;
  2333. begin
  2334.   inherited;
  2335.  
  2336.   if AChangeType=ctDestroy then exit;
  2337.  
  2338.   if AObj=FViews then exit;
  2339.  
  2340.   if IsView and (stListClearing in ViewBase.ObjState) then exit;
  2341.  
  2342.   //resort
  2343.   if(FViewSettings<>nil)and(AObj.FOwner=ViewBase)then begin
  2344.     idx:=-1;with FItems do for i:=FCount-1 downto 0 do if FItems[i]=AObj then begin idx:=i;break end;
  2345.  
  2346.     if FViewSettings.Filter(AObj)then begin//filter passed
  2347.       if(idx<0)and IsView then begin
  2348.         FItems.Append(AObj);
  2349.         idx:=FItems.FCount-1;
  2350.       end;
  2351.       if idx>=0 then begin
  2352.         FItems.Move(idx,FItems.FindNewPosBinary(idx,FViewSettings.Compare));
  2353.         NotifyChange;
  2354.       end;
  2355.     end else begin//fitered out from a view
  2356.       if(idx>=0)and IsView then begin
  2357.         FItems.Remove(idx);
  2358.         NotifyChange;
  2359.       end;
  2360.     end;
  2361.   end;
  2362.   if assigned(FViews)then with FViews.FItems do for i:=0 to FCount-1 do FItems[i].ObjectChanged(AObj,AChangeType);
  2363. end;
  2364.  
  2365. procedure THetObjectList._AppendListObj(const AListObj: THetObject);
  2366. var p:pinteger;
  2367.     i:integer;
  2368. begin
  2369.   if self<>root then with AListObj.ClassDesc do begin
  2370.     if IdProp<>nil then begin
  2371.       p:=pointer(cardinal(AListObj)+cardinal(IdProp.GetProc) and $FFFFFF);
  2372.       p^:=getNextItemId;
  2373.     end else if NameProp<>nil then begin
  2374.       {$IFNDEF NOINCREMENTALNAME}
  2375.         SetStrProp(AListObj,NameProp,getNextItemNameFor(AListObj));
  2376.       {$ENDIF}
  2377.     end;
  2378.   end;
  2379.  
  2380.   FItems.Append(AListObj);
  2381.   if assigned(FViews)then with FViews.FItems do for i:=0 to FCount-1 do FItems[i].ObjectChanged(AListObj,ctChange);
  2382.  
  2383.   //uniform?
  2384.   if not (stListNonUniform in ObjState)then
  2385.     if AListObj.ClassType<>BaseClass then
  2386.       include(ObjState,stListNonUniform);
  2387.  
  2388.   NotifyChange;
  2389. end;
  2390.  
  2391. function THetObjectList._RemoveListObj(const AListObj: THetObject):boolean;
  2392. var i:integer;
  2393. begin
  2394.   i:=IndexOf(AListObj);
  2395.   if i>=0 then begin
  2396.     FItems.Remove(i);
  2397.     if FItems.FCount=0 then Exclude(ObjState,stListNonUniform);
  2398.     result:=true;
  2399.   end else
  2400.     result:=false;
  2401.  
  2402.   if result and assigned(FViews) then with FViews.FItems do
  2403.     for i:=0 to FCount-1 do
  2404.       THetObjectList(FItems[i])._RemoveListObj(AListObj);
  2405.  
  2406.   if result then
  2407.     NotifyChange;
  2408. end;
  2409.  
  2410. procedure THetObjectList._SubObjDestroying(const AObj:THetObject);//!!!elnevezesben kavarodas van
  2411. begin
  2412.   if stListClearing in ObjState then exit;
  2413.   if _RemoveListObj(AObj)then exit;
  2414.   inherited;//subobj
  2415. end;
  2416.  
  2417. procedure THetObjectList.Clear;
  2418. var i:integer;
  2419. begin
  2420.   if FItems.FCount=0 then exit;
  2421.   ObjState:=ObjState+[stListClearing];
  2422.   try
  2423.     if not self.IsView then with FItems do begin
  2424.       for i:=FCount-1 downto 0 do
  2425.         FreeAndNil(FItems[i]);
  2426.       FCount:=0;
  2427.       setlength(FItems,0);
  2428.     end else
  2429.       FItems.Clear;
  2430.  
  2431.     if Assigned(FViews)then with FViews.FItems do for i:=0 to FCount-1 do THetObjectList(FItems[i]).Clear;
  2432.   finally
  2433.     ObjState:=ObjState-[stListClearing,stListNonUniform];
  2434.     NotifyChange;
  2435.   end;
  2436. end;
  2437.  
  2438. function THetObjectList.Count: integer;
  2439. begin
  2440.   result:=FItems.FCount;
  2441. end;
  2442.  
  2443. constructor THetObjectList.Create(const AOwner: THetObject);
  2444. begin
  2445.   inherited;
  2446.   ObjState:=ObjState+[stListActive];//!!! Ez mar a hetobjba kellene
  2447.   FBaseClass:=GetBaseClass;
  2448. end;
  2449.  
  2450. destructor THetObjectList.Destroy;
  2451. begin
  2452.   FreeAndNil(FViews);
  2453.   FreeAndNil(FViewSettings);
  2454.  
  2455.   Clear;
  2456.   inherited;
  2457. end;
  2458.  
  2459. function THetObjectList.dump(const AIndent: integer): ansistring;
  2460. var i:integer;
  2461. begin
  2462.   result:=inherited dump(AIndent);
  2463.   result:=result+indent('  ',aindent)+'View:'+ViewDefinition+#13#10;
  2464.   if assigned(FViews)then for i:=0 to FViews.Count-1 do begin
  2465.     result:=result+THetObjectList(FViews.GetHetObjByIndex(i)).dump(AIndent+2);
  2466.   end;
  2467.   result:=result+indent('  ',aindent)+'Items:'+tostr(Count)+#13#10;
  2468.   for i:=0 to Count-1 do
  2469.     result:=result+GetHetObjByIndex(i).dump(AIndent+1);
  2470. end;
  2471.  
  2472. function THetObjectList.GetBaseClass: THetObjectClass;
  2473. var cn:ansistring;
  2474.     cd:TClassDescription;
  2475. begin
  2476.   result:=nil;
  2477.   cn:=FindBetween(ClassParent.ClassName,'<','>');
  2478.   cn:=ListItem(cn,ListCount(cn,'.')-1,'.');
  2479.   if cn<>'' then begin
  2480.     cd:=ClassDescriptionOf(cn);
  2481.     if cd<>nil then
  2482.       result:=THetObjectClass(cd.FClass);
  2483.   end;
  2484. end;
  2485.  
  2486. function THetObjectList.GetByNameCached(const AName: ansistring): THetObject;
  2487. begin
  2488.   result:=nil;
  2489. end;
  2490.  
  2491. function THetObjectList.UniqueName(const AName:ansistring='';const AlwaysIndex:boolean=false):ansistring;
  2492. var i,Idx,MaxIdx:integer;
  2493.     n1,n2,sIdx:ansistring;
  2494. begin
  2495.   if AName='' then exit(UniqueName('noname'));
  2496.   if not AlwaysIndex and(GetHetObjByName(AName)=nil)then exit(AName);
  2497.  
  2498.   n1:=AName;while(n1<>'')and(n1[length(n1)]in['0'..'9']) do setlength(n1,length(n1)-1);
  2499.   if n1='' then n1:='noname';
  2500.  
  2501.   MaxIdx:=1;
  2502.   for i:=0 to Count-1 do begin
  2503.     n2:=FItems.FItems[i].getName;
  2504.     if cmp(copy(n2,1,length(n1)),n1)=0 then begin
  2505.       sIdx:=copy(n2,length(n1)+1,100);
  2506.       idx:=strtointdef(sIdx,0)+1;
  2507.       if Idx>MaxIdx then
  2508.         MaxIdx:=Idx;
  2509.     end;
  2510.   end;
  2511.   result:=n1+toStr(maxIdx);
  2512. end;
  2513.  
  2514. function THetObjectList.GetViewByHash(const AHash: integer): THetObjectListView;
  2515. var idx:integer;
  2516. begin
  2517.   if IsView then exit(THetObjectList(FOwner).GetViewByHash(AHash));
  2518.   if Assigned(FViewSettings)and(FViewSettings.FHash=AHash)then exit(THetObjectListView(self));
  2519.   if Assigned(FViews) then if FViews.FItems.FindBinary(function(const a:THetObject):integer begin result:=THetObjectListView(a).GetViewHash-AHash end,idx)then
  2520.     exit(THetObjectListView(FViews.FItems.FItems[idx]));
  2521.   result:=nil;
  2522. end;
  2523.  
  2524. procedure THetObjectList.CopyItemsFrom(const ASrc:THetObjectList);
  2525. begin
  2526.   FItems.FCount:=ASrc.FItems.FCount;
  2527.   setlength(FItems.FItems,FItems.FCount);
  2528.   system.move(ASrc.FItems.FItems[0],FItems.FItems[0],length(FItems.FItems)*sizeof(ASrc.FItems.FItems[0]));
  2529. end;
  2530.  
  2531. procedure THetObjectList.RefreshView;
  2532. var i:integer;
  2533.     o:THetObject;
  2534. begin
  2535.   if FViewSettings=nil then exit;
  2536.   if IsView then begin
  2537.     if length(FViewSettings.FWhereAnd)=0 then begin
  2538.       CopyItemsFrom(THetObjectList(FOwner.FOwner))
  2539.     end else begin
  2540.       FItems.Clear;
  2541.       for i:=0 to THetObjectList(FOwner.FOwner).FItems.FCount-1 do begin
  2542.         o:=THetObjectList(FOwner.FOwner).FItems.FItems[i];
  2543.         if FViewSettings.Filter(o)then
  2544.           FItems.Append(o);
  2545.       end;
  2546.     end;
  2547.  
  2548.   end;
  2549.  
  2550.   Sort;
  2551. end;
  2552.  
  2553. function THetObjectList.CreateListView:THetObjectListView;
  2554. begin
  2555.   result:=THetObjectListView.Create(FViews);
  2556. end;
  2557.  
  2558. function THetObjectList.GetViewByDef(const ADef: ansistring): THetObjectListView;
  2559. var h:integer;
  2560. begin
  2561.   if IsView then exit(ViewBase.GetViewByDef(ADef));
  2562.   h:=Crc32UC(ADef);
  2563.   result:=GetViewByHash(h);if assigned(result)then exit;
  2564.   if FViews=nil then begin
  2565.     ObjState:=ObjState-[stListActive];
  2566.     FViews:=THetObjectList.Create(self);
  2567.     ObjState:=ObjState+[stListActive];
  2568. {    FViews.FViewSettings:=THetObjectViewSettings.Create;
  2569.     FViews.FViewSettings.Definition:='hash';}
  2570.     FViews.ViewDefinition:='hash';
  2571.   end;
  2572.  
  2573.   result:=CreateListView;
  2574.   with result do begin
  2575.     FViewSettings:=THetObjectViewSettings.create;
  2576.     FViewSettings.Definition:=ADef;
  2577.     Result.NotifyChange;//sort
  2578.   end;
  2579.   result.RefreshView;
  2580.  
  2581. {    if length(FViewSettings.FWhereAnd)=0 then begin
  2582.       CopyItemsFrom(self)
  2583.     end else begin
  2584.       FItems.Clear;
  2585.       for i:=0 to self.FItems.FCount-1 do begin
  2586.         o:=self.FItems.FItems[i];
  2587.         if FViewSettings.Filter(o)then
  2588.           FItems.Append(o);
  2589.       end;
  2590.     end;
  2591.     Sort;
  2592.   end;}
  2593.  
  2594. end;
  2595.  
  2596. function THetObjectList.GetViewDefinition: ansistring;
  2597. begin
  2598.   if assigned(FViewSettings) then result:=FViewSettings.Definition
  2599.                              else result:='';
  2600. end;
  2601.  
  2602. procedure THetObjectList.SetViewDefinition(const Value: ansistring);
  2603. begin
  2604.   if Value=ViewDefinition then exit;
  2605.   if(Value<>'')and(FViewSettings=nil)then
  2606.     FViewSettings:=THetObjectViewSettings.Create;
  2607.   if assigned(FViewSettings) then begin
  2608.     FViewSettings.Definition:=Value;
  2609.     //RefreshView
  2610.   end;
  2611. end;
  2612.  
  2613. function THetObjectList.GetViewHash: integer;
  2614. begin
  2615.   if assigned(FViewSettings) then result:=FViewSettings.Hash
  2616.                              else result:=0;
  2617. end;
  2618.  
  2619. type
  2620.   TViewDefinitionRec=record
  2621.     Order,Filter:ansistring;
  2622.   end;
  2623.  
  2624. function DecodeViewDefinition(const def:ansistring):TViewDefinitionRec;
  2625. begin
  2626.   result.Order:=ListItem(def,0,'|');
  2627.   result.Filter:=copy(def,length(result.Order)+2);
  2628. end;
  2629.  
  2630. function EncodeViewDefinition(const order,filter:ansistring):ansistring;
  2631. begin
  2632.   result:=order;
  2633.   if filter<>'' then
  2634.     result:=result+'|'+filter;
  2635. end;
  2636.  
  2637. function THetObjectList.ViewAdjustFilter(const ANewFilter:ansistring):THetObjectList;
  2638. begin
  2639.   with DecodeViewDefinition(ViewDefinition)do
  2640.     result:=View[EncodeViewDefinition(order,ANewFilter)];
  2641. end;
  2642.  
  2643. function THetObjectList.ViewAdjustOrder(const ANewOrder:ansistring):THetObjectList;
  2644. begin
  2645.   with DecodeViewDefinition(ViewDefinition)do
  2646.     result:=View[EncodeViewDefinition(ANewOrder,filter)];
  2647. end;
  2648.  
  2649. function THetObjectList.ViewBase: THetObjectList;
  2650. begin
  2651.   if IsView then result:=THetObjectList(FOwner.FOwner)
  2652.             else result:=self;
  2653. end;
  2654.  
  2655. { TGenericHetObjectList<T> }
  2656.  
  2657. constructor TGenericHetObjectList<T>.Create(const AOwner: THetObject);
  2658. var i,j:integer;
  2659. begin
  2660.   inherited;
  2661. //  j:=VMTIndex(self,@THetObjectList._SafeGetByIndex);PatchVMT(self,j+3*4,j);
  2662. //  j:=VMTIndex(self,@THetObjectList._SafeGetById);PatchVMT(self,j+3*4,j);
  2663. //  j:=VMTIndex(self,@THetObjectList._SafeGetByName);PatchVMT(self,j+3*4,j);
  2664. end;
  2665.  
  2666. //mappings
  2667.  
  2668. function TGenericHetObjectList<T>.GetById(const AId: integer): T;
  2669. begin
  2670.   result:=T(GetHetObjById(AId));
  2671. end;
  2672.  
  2673. function TGenericHetObjectList<T>.GetByIndex(const AIndex: integer): T;
  2674. begin
  2675.   result:=T(GetHetObjByIndex(AIndex));
  2676. end;
  2677.  
  2678. function TGenericHetObjectList<T>.GetByName(const AName: ansistring): T;
  2679. begin
  2680.   result:=T(GetHetObjByName(AName));
  2681. end;
  2682.  
  2683. function TGenericHetObjectList<T>.GetViewByDef(const ADef:ansistring):TGenericHetObjectListView<T>;
  2684. begin
  2685.   result:=TGenericHetObjectListView<T>(THetObjectListView(self).GetViewByDef(ADef));
  2686. end;
  2687.  
  2688. function TGenericHetObjectList<T>.NewListObj(const BaseClass: THetObjectClass): THetObject;
  2689. begin
  2690.   result:=BaseClass.Create(self);
  2691. end;
  2692.  
  2693. function TGenericHetObjectList<T>.ViewBase: TGenericHetObjectList<T>;
  2694. begin
  2695.   result:=TGenericHetObjectList<T>(THetObjectList(Self).ViewBase);
  2696. end;
  2697.  
  2698. function TGenericHetObjectList<T>.NewListObj: T;
  2699. begin
  2700.   result:=T(GetBaseClass.Create(ViewBase));
  2701. end;
  2702.  
  2703. function TGenericHetObjectList<T>.CreateListView: THetObjectListView;
  2704. begin
  2705.   result:=TGenericHetObjectListView<T>.Create(FViews);
  2706. end;
  2707.  
  2708. procedure TGenericHetObjectList<T>.ForEach(const proc:TProc<T>);
  2709. var i:integer;o:THetObject;
  2710. begin
  2711.   i:=0;
  2712.   with FItems do while i<FCount do begin
  2713.     o:=FItems[i];
  2714.     proc(o);
  2715.     if(i<FCount)and(o=FItems[i])then
  2716.       inc(i);//delete safe
  2717.   end;
  2718. end;
  2719.  
  2720. { TGenericHetObjectList<T>.TEnumerator }
  2721.  
  2722. {$IFDEF ENUMERATORS}
  2723. constructor TGenericHetObjectList<T>.TEnumerator.Create(
  2724.   AList: TGenericHetObjectList<T>);
  2725. begin
  2726.   FList:=AList;
  2727.   FIndex:=-1;
  2728. end;
  2729.  
  2730. function TGenericHetObjectList<T>.TEnumerator.DoGetCurrent: T;
  2731. begin
  2732.   result:=FList.ByIndex[FIndex];
  2733. end;
  2734.  
  2735. function TGenericHetObjectList<T>.TEnumerator.DoMoveNext: Boolean;
  2736. begin
  2737.   inc(FIndex);
  2738.   result:=(FIndex<FList.Count);
  2739. end;
  2740.  
  2741. function TGenericHetObjectList<T>.GetEnumerator: TEnumerator;
  2742. begin
  2743.   result:=TEnumerator.Create(self);
  2744. end;
  2745. {$ENDIF}
  2746.  
  2747. var _ClassDescriptionCache:TClassDescriptionCache=nil;
  2748.  
  2749. function ClassDescriptionCache:TClassDescriptionCache;
  2750. begin
  2751.   if _ClassDescriptionCache=nil then
  2752.     _ClassDescriptionCache:=TClassDescriptionCache.Create;
  2753.   result:=_ClassDescriptionCache;
  2754. end;
  2755.  
  2756. type
  2757.   TSelfTest=class(THetObject)
  2758.   private
  2759.     FName: ansistring;
  2760.     FValue: integer;
  2761.     procedure SetName(const Value: ansistring);
  2762.     procedure SetValue(const Value: integer);
  2763.   published
  2764.     property Name:ansistring read FName write SetName;
  2765.     property Value:integer read FValue write SetValue;
  2766.   end;
  2767.  
  2768.   TSelfTests=class(TGenericHetObjectList<TSelfTest>)
  2769.   public
  2770.     property ByName;default;
  2771.   end;
  2772.  
  2773. { TSelfTest }
  2774.  
  2775. {$O-}
  2776. procedure TSelfTest.SetName(const Value: ansistring);begin end;
  2777. procedure TSelfTest.SetValue(const Value: integer);begin end;
  2778. {$O+}
  2779.  
  2780. procedure SelfTest;
  2781. var list:TSelfTests;
  2782.     s:ansistring;
  2783.     i:integer;
  2784. begin
  2785.   try
  2786.     list:=TSelfTests.Create(nil);
  2787.     try
  2788.       //test lists, views
  2789.  
  2790.       TSelfTest.Create(list).Name:='Zoltan';
  2791.       TSelfTest.Create(list).Name:='Bea';
  2792.       TSelfTest.Create(list).Name:='Aladar';
  2793.       TSelfTest.Create(list).Name:='Emese';
  2794.       TSelfTest.Create(list).Name:='Denes';
  2795.  
  2796.       list['Denes'].Value:=5;
  2797.       list['Bea'].Value:=3;
  2798.       list['Aladar'].Value:=2;
  2799.       list['Zoltan'].Value:=1;
  2800.       list['Emese'].Value:=3;
  2801.  
  2802.       with list.View['-Value,Name|Value>1']do
  2803.         for i:=0 to Count-1 do
  2804.           s:=s+Eval('Name&Value',GetHetObjByIndex(i));
  2805.  
  2806.       if s<>'Denes5Bea3Emese3Aladar2' then
  2807.         raise Exception.Create('ListView test failed');
  2808.  
  2809.     finally
  2810.       list.Free;
  2811.     end
  2812.   except
  2813.     on e:exception do raise Exception.Create('FATAL ERROR: HetObj.SelfTest FAILED ('+e.Message+')');
  2814.   end;
  2815. end;
  2816.  
  2817. { TIOTestSubObj }
  2818. {$O-}
  2819. procedure TIOTestSubObj.SetByte(const Value: byte);begin end;
  2820. { TIOTestNamedObj }
  2821. procedure TIOTestNamedObj.SetByte(const Value: byte);begin end;
  2822. procedure TIOTestNamedObj.SetName(const Value: TName);begin end;
  2823. { TIOTestIdedObj }
  2824. procedure TIOTestIdedObj.SetByte(const Value: byte);begin end;
  2825. { TIOTestIndexedObj }
  2826. procedure TIOTestIndexedObj.SetByte(const Value: byte);begin end;
  2827. { TIOTestHetObj }
  2828. procedure TIOTestObj.SetAnsiString(const Value: AnsiString);begin end;
  2829. procedure TIOTestObj.SetBoolean(const Value: Boolean);begin end;
  2830. procedure TIOTestObj.SetByte(const Value: byte);begin end;
  2831. procedure TIOTestObj.Setcardinal(const Value: cardinal);begin end;
  2832. procedure TIOTestObj.SetDate(const Value: TDate);begin end;
  2833. procedure TIOTestObj.SetDateTime(const Value: TDateTime);begin end;
  2834. procedure TIOTestObj.SetDouble(const Value: Double);begin end;
  2835. procedure TIOTestObj.SetExtended(const Value: Extended);begin end;
  2836. procedure TIOTestObj.SetIDedObj(const Value: TIOTestIDedObj);begin end;
  2837. procedure TIOTestObj.SetIndexedObj(const Value: TIOTestIndexedObj);begin end;
  2838. procedure TIOTestObj.Setint64(const Value: int64);begin end;
  2839. procedure TIOTestObj.Setinteger(const Value: integer);begin end;
  2840. procedure TIOTestObj.SetIOTestEnum(const Value: TIOTestEnum);begin end;
  2841. procedure TIOTestObj.SetIOTestSet(const Value: TIOTestSet);begin end;
  2842. procedure TIOTestObj.SetNamedObj(const Value: TIOTestNamedObj);begin end;
  2843. procedure TIOTestObj.SetShortInt(const Value: ShortInt);begin end;
  2844. procedure TIOTestObj.SetSingle(const Value: Single);begin end;
  2845. procedure TIOTestObj.SetSmallInt(const Value: SmallInt);begin end;
  2846. procedure TIOTestObj.SetSubObj(const Value: TIOTestSubObj);begin end;
  2847. procedure TIOTestObj.SetTime(const Value: TTime);begin end;
  2848. procedure TIOTestObj.Setuint64(const Value: uint64);begin end;
  2849. procedure TIOTestObj.SetUnicodeString(const Value: UnicodeString);begin end;
  2850. procedure TIOTestObj.SetWord(const Value: Word);begin end;
  2851. {$O+}
  2852.  
  2853. var
  2854.   namedList:TIOTestNamedObjList;
  2855.   IdedList:TIOTestIdedObjList;
  2856.   IndexedList:TIOTestIndexedObjList;
  2857.  
  2858.  
  2859. procedure _IOTest;
  2860.   procedure error(s:string);begin raise Exception.Create('IOTest failed:');end;
  2861.  
  2862. var o:TIOTestObj;
  2863.  
  2864.     named:TIOTestNamedObj;
  2865.     Ided:TIOTestIdedObj;
  2866.     Indexed:TIOTestIndexedObj;
  2867.  
  2868.     st:TIO;
  2869.  
  2870.     ow:THetObjectList;
  2871. begin
  2872.   ow:=THetObjectList.Create(nil);//parent for lists
  2873.  
  2874.   namedList:=TIOTestNamedObjList.Create(ow);named:=TIOTestNamedObj.Create(namedList);named.Name:='NAME';
  2875.   IdedList:=TIOTestIdedObjList.Create(ow);Ided:=TIOTestIdedObj.Create(IdedList);
  2876.   IndexedList:=TIOTestIndexedObjList.Create(ow);
  2877.     {Indexed:=}TIOTestIndexedObj.Create(IndexedList);
  2878.     Indexed:=TIOTestIndexedObj.Create(IndexedList);//idx=1
  2879.  
  2880.   o:=TIOTestObj.Create(ow);
  2881.  
  2882.   o._int64:=$7766554433221100;
  2883.   o._uint64:=$8866554433221100;
  2884.   o._Single:=1.2345;
  2885.   o._double:=2.3456;
  2886.   o._extended:=3.4567;
  2887.   o._Date:=123456;
  2888.   o._Time:=0.123;
  2889.   o._DateTime:=123456.123;
  2890.   o._AnsiString:='AnsiString';
  2891.   o._UnicodeString:='UnicodeString'#1234'ENDS';
  2892.   o._SubObj._Byte:=$AA;
  2893.   o._NamedObj:=named;
  2894.   o._IDedObj:=Ided;
  2895.   o._IndexedObj:=Indexed;
  2896.  
  2897. //  o.SaveToFile(stBin,'c:\hetObj_old.bin');
  2898.  
  2899.   st:=TIOBinWriter.Create;
  2900.   st.FObjStorageFormat:=sfBin;
  2901.   st.io(TObject(o));
  2902. //  TFile('c:\hetObj.bin').Write(st.Data);
  2903.   st.Free;
  2904.  
  2905.   ow.Free;
  2906. end;
  2907.  
  2908. { TGenericHetObjectListView<T> }
  2909.  
  2910. function TGenericHetObjectListView<T>.GetById(const AId: integer): T;
  2911. begin
  2912.   result:=T(GetHetObjById(AId));
  2913. end;
  2914.  
  2915. function TGenericHetObjectListView<T>.GetByIndex(const AIndex: integer): T;
  2916. begin
  2917.   result:=T(GetHetObjByIndex(AIndex));
  2918. end;
  2919.  
  2920. function TGenericHetObjectListView<T>.GetByName(const AName: ansistring): T;
  2921. begin
  2922.   result:=T(GetHetObjByName(AName));
  2923. end;
  2924.  
  2925. function TGenericHetObjectListView<T>.GetEnumerator: TEnumerator<T>;
  2926. begin
  2927.   result:=TGenericHetObjectList<T>(self).getEnumerator;
  2928. end;
  2929.  
  2930. procedure TGenericHetObjectListView<T>.ForEach(const proc:TProc<T>);
  2931. var a:TArray<T>; o:T;
  2932. begin
  2933.   setlength(a,FItems.FCount);
  2934.   system.move(pointer(FItems.FItems)^,pointer(a)^,length(a)shl 2);
  2935.   for o in a do proc(o);
  2936. end;
  2937.  
  2938.  
  2939. initialization
  2940.   RttiContext:=TRttiContext.Create.Create;
  2941.   PatchInitPropertySetterFunctions(@THetObject._AddReference,@THetObject._RemoveReference);
  2942.  
  2943.   PPointer(@Root)^:=THetObjectList.Create(nil);
  2944.  
  2945.   SelfTest;
  2946.   _IOTest;
  2947. finalization
  2948.   FreeAndNil(PPointer(@Root)^);
  2949.  
  2950.   FreeAndNil(_ClassDescriptionCache);
  2951.   RttiContext.Free;
  2952.   //!!!!!!!!!!!!!  QRVANAGY BUG d2009, valami miatt ez a hetfilesys.pas a hetobj.PAS elott hivodik meg
  2953.   //debug kell
  2954. end.
  2955.  
  2956.  
  2957.   SelfTest;
  2958.   _IOTest;
  2959. finalization
  2960.   FreeAndNil(PPointer(@Root)^);
  2961.  
  2962.   FreeAndNil(_ClassDescriptionCache);
  2963.   RttiContext.Free;
  2964.   //!!!!!!!!!!!!!  QRVANAGY BUG d2009, valami miatt ez a hetfilesys.pas a hetobj.PAS elott hivodik meg
  2965.   //debug kell
  2966. end.
Advertisement
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!