3ddark

Delphi Simple ORM using ZeosDBO https://github.com/3ddark/delphi-orm-test Two different version. v2 supported actions function GetList(AClass: TClass; var AList: TArray<TTable>; AFilter: string; ALock: Boolean; APermissionCheck: Boolean=True): Boolean; function GetListCustom(AClass: TClass; var AList: TArray<TTable>; AFields: TArray<TFieldDB>; AFilter: string; ALock: Boolean; APermissionCheck: Boolean=True): Boolean; function GetOne(ATable: TTable; AFilter: string; ALock: Boolean; APermissionCheck: Boolean=True): Boolean; overload; function GetOneCustom(ATable: TTable; AFields: TArray<TFieldDB>; AFilter: string; ALock: Boolean; APermissionCheck: Boolean=True): Boolean; overload; function GetOne(ATable: TTable; AID: Int64; ALock: Boolean; APermissionCheck: Boolean=True): Boolean; overload; function GetOneCustom(ATable: TTable; AFields: TArray<TFieldDB>; AID: Int64; ALock: Boolean; APermissionCheck: Boolean=True): Boolean; overload; function Insert(ATable: TTable; APermissionCheck: Boolean=True): Boolean; virtual; function Update(ATable: TTable; APermissionCheck: Boolean=True): Boolean; virtual; function CustomUpdate(ATable: TTable; AFields: TArray<TFieldDB>; APermissionCheck: Boolean=True): Boolean; virtual; function DeleteBatch(AClass: TClass; AFilter: string; APermissionCheck: Boolean=True): Boolean; overload; function DeleteBatch(ATables: TArray<TTable>; APermissionCheck: Boolean=True): Boolean; overload; function Delete(ATable: TTable; APermissionCheck: Boolean=True): Boolean; virtual; function LogicalSelect(AClass: TClass; var ATable: TTable; AFilter: string; ALock, AWithBegin, APermissionCheck: Boolean; AProcBusinessSelect: TBusinessSelectEvent): TEntityManager; virtual; function LogicalInsert(ATable: TTable; AWithBegin, AWithCommit, APermissionCheck: Boolean; AProcBusinessInsert: TBusinessOperationEvent): Boolean; virtual; function LogicalUpdate(ATable: TTable; AWithBegin, AWithCommit, APermissionCheck: Boolean; AProcBusinessUpdate: TBusinessOperationEvent): Boolean; virtual; function LogicalDelete(ATable: TTable; AWithBegin, AWithCommit, APermissionCheck: Boolean; AProcBusinessDelete: TBusinessOperationEvent): Boolean; virtual; procedure Listen(ATableName: string); virtual; procedure Unlisten(ATableName: string); virtual; procedure Notify(ATableName: string); virtual; function IsAuthorized(ATableSourceCode: string; APermissionType: TPermissionType; APermissionCheck: Boolean; AShowException: Boolean=True): Boolean; procedure Start(AConnection: TZAbstractConnection = nil); procedure Commit(AConnection: TZAbstractConnection = nil); procedure Rollback(AConnection: TZAbstractConnection = nil); frmMain contain example for using methods

Can you explain with an example?

[Entity('addresses', 'public')] TAddress = class(TEntity) private FCity: string; FCountry: string; public [Column('city')] property City: string read FCity write FCity; [Column('country')] property Country: string read FCountry write FCountry; end; [Entity('persons', 'public')] TPerson = class(TEntity) private FName: string; FSurName: string; FAddress: TAddress; function GetFullName: string; public [Column('name')] property Name: string read FName write FName; [Column('sur_name')] property SurName: string read FSurName write FSurName; [NotMapped] property FullName: string read GetFullName; [OneToOne('')] property Address: TAddress read FAddress write FAddress; //Access this property and modify (like City='Istanbul', Country='Turkey') end; //////////////////////////////// function TEntity.GetQuery(AID: Int64; AWithSchema: Boolean): string; var ACtx: TRttiContext; AType: TRttiType; AProp : TRttiProperty; LAttr : TCustomAttribute; LColName : string; LTableName : string; LColNames: string; LColID: string; begin ACtx := TRttiContext.Create; try AType := ACtx.GetType(SomeClass.ClassType); LTableName := Self.GetTableName(AWithSchema); LColNames := ''; for AProp in AType.GetProperties do begin if AProp.Visibility in [mvPublished, mvPublic] then begin for LAttr in AProp.GetAttributes do begin if LAttr is Column then begin LColName := Column(LAttr).ColumnName; if LColName = '' then raise Exception.Create('Column must bu declared.' + sLineBreak + 'If it not used, declare "NotMapped" attribute!!!'); if LColName = 'id' then LColID := LColName else LColNames := LColNames + LColName + ','; end; end; end; end; if LColNames = '' then raise Exception.Create('SQL field_names not found!!!'); LColNames := LColID + ',' + LColNames; Result := Trim('SELECT ' + LeftStr(LColNames, Length(LColNames)-1) + ' FROM ' + LTableName + ' WHERE ' + LeftStr(LColNames, 2) + '=' + IntToStr(AID)); finally ACtx.Free; end; end; /////////////////////////////////////////// procedure Test var ACtx: TRttiContext; AType: TRttiType; AProp, AProp2: TRttiProperty; LAttr: TCustomAttribute; LInst: TRttiInstanceType; ARelations: TArray<TRttiProperty>; LColName: string; LTableName: string; LColNames: string; LColID: string; LClass: TClass; LPointer: Pointer; begin ACtx := TRttiContext.Create; try AType := ACtx.GetType(SomeModel.ClassType); SetLength(ARelations, 0); for AProp in AType.GetProperties do begin if (AProp.PropertyType.TypeKind = tkClass) and (AProp.IsReadable) and (AProp.IsWritable) and (AProp.Visibility in [mvPublished, mvPublic]) then begin for LAttr in AProp.GetAttributes do begin //access here class property and fill an array if (LAttr is OneToOne) or (LAttr is OneToMany) then begin SetLength(ARelations, Length(ARelations) + 1); AReletions[Length(ARelations) - 1] := AProp; Break; end; end; end; end; for AProp in ARelations do begin //HEREEEEE I WANT TO ACCESS model and update property values LInst := AProp.PropertyType.AsInstance; Move(LInst, LPointer, SizeOf(Pointer)); AType := ACtx.GetType(LInst.Handle); for AProp2 in AType.GetProperties do begin if (AProp2.Visibility in [mvPublished, mvPublic]) then begin for LAttr in AProp2.GetAttributes do begin if (LAttr is ColumnAttribute) then begin if (AProp2.PropertyType.TypeKind = tkString) or (AProp2.PropertyType.TypeKind = tkUString) or (AProp2.PropertyType.TypeKind = tkWString) then begin AProp2.SetValue(LPointer, 'Orange'); Break; end; end; end; end; end; LClass := AProp.PropertyType.AsInstance.MetaclassType; end; finally ACtx.free; end; end; I want to access Address (FAddress) property and edited city and/or country values. I can do anything in simple class with RTTI I can do all SELECT, INSERT, UPDATE, DELETE operations. But in order to be able to perform operations in classes with Relations, I must be able to perform the necessary operations to access these classes. I'll add the Github link after I've made the final code edits. I may have shown the exact code I wrote and the missing part. NOTE: The codes may not work fully, I added it as a representation.

Thanks for your support @Remy Lebeau Here is the Github Repo. Use Zeos DB Connection and use PostgreSQL database Simple class GetByID => Done Simple class with OneToOne => Done Simple class with OneToMany => waiting. I use to TArray<TAnyEntityClass> tkDynArray fill all data After the GetById operation is done. I will add other features and check all

I was able to make the change exactly as you said in the tests I did last night. Can I convert AProp2 to T? Why do I need this? I have a function like GetByID(AID: Int64; ALock: Boolean = False) I want to Recursive invoke properties that come as tkClass and contain attributes "OneOne" or "OneMany". (* Person Table id name sur_name address_id 1 3ddark Thunder 2 Address Table id city country 1 Ankara Turkey 2 Istanbul Turkey *) var LMan: TEntityManager; LPerson: TPerson; begin LMan := TEntityManager.Create(DBConnection); LPerson := LMan.GetById<TPerson>(1, False); //Here once call and see tkClass recursive call Address, or any class relations Writeln(LPerson.Id.ToString()); //1 Writeln(LPerson.Name); //3ddark Writeln(LPerson.SurName); //Thunder Writeln(LPerson.Address.Id.ToString()); //2 Writeln(LPerson.Address.City); //Istanbul Writeln(LPerson.Address.Country); //Turkey end; function TEntityManager.GetById<T>(AID: Int64, ALock: Boolean = False): T; var LRelationID: Int64; ... LObj: TObject; ... begin ... for AProp in ARelations do begin LObj := AProp.GetValue(SomeModel).AsObject; LClass := LObj.ClassType; //Normally TPerson when T comes first //But I need TAddress or any relations TXXX class as T AProp.SetValue(LObj, Self.GetById<(*Here dynamic classType like TAddress or TXxxx --->*)LObj.ClassType>(LRelationID, ALock)).AsObject; end; ... end; I hope I was able to explain my problem. Thanks in advance.

Hello,Can I access the attribute value of only one property? For example : var LDay: TSysDay; LFieldName: string; LFieldName := GetAttribute(LDay.Day); Sending a property of the class, such as getting the attribute information of it. type TFieldNameAttribute = class(TCustomAttribute) strict private FName: string; public property Name: string read FName; constructor Create(AName: string); end; //---------------------------------------------------- type [TSchemaNameAttribute('public')] [TTableNameAttribute('sys_days')] TSysDay = class(TTableBase) private FId: Int64; FDay: WideString; procedure SetId(const Value: Int64); procedure SetDay(const Value: WideString); public [TFieldNameAttribute('id')] property Id: Int64 read FId write SetId; [TFieldNameAttribute('day')] property Day: WideString read FDay write SetDay; end; //--------------------------------------- function TTable.GetTableName: string; var LC: TRttiContext; LT: TRttiType; LA: TCustomAttribute; begin Result := ''; LC := TRttiContext.Create; try LT := LC.GetType(Self.ClassType); for LA in LT.GetAttributes() do if LA is TTableNameAttribute then begin Result := TTableNameAttribute(LA).Name; Exit; end; //Result is "sys_day" finally LC.Free end; end; //--------------------------------------- function TTable.GetFieldNames: string; var LC: TRttiContext; LT: TRttiType; LP: TRttiProperty; LA: TCustomAttribute; begin Result := ''; LC := TRttiContext.Create; try LT := LC.GetType(Self.ClassType); for LP in LT.GetProperties() do for LA in LP.GetAttributes() do if LA is TFieldNameAttribute then Result := Result + TFieldNameAttribute(LA).Name + ', '; if Trim(Result) <> '' then begin Result := Trim(Result); Result := LeftStr(Result, Length(Result)-1); end; //Result is "id, day" finally LC.Free end; end;

Thank you remmy

type [TTableNameAttribute('sys_days')] TSysDay = class(TTableBase) private FId: Int64; FDay: WideString; ... ... ... public [TFieldNameAttribute('id')] property Id: Int64 read FId write SetId; [TFieldNameAttribute('day')] property Day: WideString read FDay write SetDay; [TFieldNameAttribute('a')] property A: WideString [TFieldNameAttribute('b')] property B: Int64 [TFieldNameAttribute('c')] property C: Double end; Can I just get the value of an attribute GetFieldAttribe('a'); //wrong example. Here I can check and find in the loop with the incoming parameter GetFieldAttribe(Self.A); //correct example. Here A is WideString Member. Not a class, not a object

I know it's a stupid question. Can I get the attribute value for only one property? Without sending any information as a string. As an example I get the TableName via ClassType Table is an object. But properties not and object

The sort function is working. But when I sort for 100000 rows, it works very slowly. What suggestions do you have for better performance. I'm only sorting for one column at a time. No multiple sorting procedure TStringGrid.SortStringGrid(ACol: Integer); var i, j : Integer; LTemp: TStringList; LSortType: TSortMode; LCompResult: Boolean; begin Perform(WM_SETREDRAW, 0, 0); LTemp := TStringList.Create; try LSortType := smNone; for i := Self.FixedRows to Self.RowCount - 2 do begin for j:= i+1 to Self.RowCount-1 do begin //first sort or another column sort if (FSortType = smNone) or (FSortType = smDesc) or ((FSortType = smAsc) and (FSortCol <> ACol)) then begin if AnsiCompareText(Self.Cells[ACol, i], Self.Cells[ACol, j]) = GreaterThanValue then begin LTemp.Assign(Self.Rows[j]); Self.Rows[j].Assign(Self.Rows[i]); Self.Rows[i].Assign(LTemp); end; LSortType := smAsc; end else if (FSortType = smAsc) and (FSortCol = ACol) then //sort same column asc to desc begin if AnsiCompareText(Self.Cells[ACol, i], Self.Cells[ACol, j]) = LessThanValue then begin LTemp.Assign(Self.Rows[i]); Self.Rows[i].Assign(Self.Rows[j]); Self.Rows[j].Assign(LTemp); end; LSortType := smDesc; end; end; end; FSortType := LSortType; FSortCol := ACol; finally LTemp.free; Perform(WM_SETREDRAW, 1, 0); Invalidate; end; end;

How to wait for the above thread to finish before the main thread freezes? procedure TForm2.Button1Click(Sender: TObject); var Thrd : TThread; msg: tagMSG; Ret: Cardinal; begin Thrd := TThread.CreateAnonymousThread( procedure begin Sleep(10000); Memo1.Lines.Add('End of Thread'); end ); Thrd.Start; //The thread above is waiting for 10 seconds within itself. We will wait for the above thread to finish before the main thread freezes Ret := MsgWaitForMultipleObjects(0, Thrd, True, INFINITE, QS_ALLINPUT); //use with WaitMessage case Ret of WAIT_OBJECT_0: ; WAIT_OBJECT_0+1: ; WAIT_TIMEOUT: ; end; Memo1.Lines.Add('Thread finish'); end;

This is another solution unit MsgWaitForMultiple; interface uses Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, System.SyncObjs; type TForm3 = class(TForm) Memo1: TMemo; Button1: TButton; procedure Button1Click(Sender: TObject); procedure FormCreate(Sender: TObject); private public Event: TEvent; end; var Form3: TForm3; implementation {$R *.dfm} procedure TForm3.Button1Click(Sender: TObject); var Thrd : TThread; begin Event.ResetEvent; Thrd := TThread.CreateAnonymousThread( procedure begin Sleep(10000); Event.SetEvent; end ); Thrd.Start; while Event.WaitFor(0) = wrTimeOut do begin WaitMessage; Application.ProcessMessages; end; Memo1.Lines.Add('Thread bitti'); end; procedure TForm3.FormCreate(Sender: TObject); begin Event := TEvent.Create(nil, True, False, ''); end; end.

@FPiette Add for loging I added deliberately

Hello, I want to move rows in StringGrid, a Delphi component. (Delphi 7, TStringGrid) I fill the information in the stringrid as shown in the picture below. I also adjust the stringgrid settings. There is no problem with move to row sGrid.FixedCols := 1; sGrid.FixedRows := 1; sGrid.Options := sGrid.Options + [goRowMoving]; procedure TFormX.sGridMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var gc: TGridCoord; begin if Sender is TStringGrid then begin if TStringGridX(Sender).GridState in [gsRowMoving] then begin TStringGrid(Sender).MouseToCell(X, Y, gc.X, gc.Y); //get the row number of the first selected row FFromIndex := gc.Y; end; end; end; procedure TFormX.sGridMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var gc: TGridCoord; begin if Sender is TStringGrid then begin if TStringGridX(Sender).GridState in [gsRowMoving] then begin TStringGrid(Sender).MouseToCell(X, Y, gc.X, gc.Y); FToIndex := gc.Y; end; end; end; procedure TFormX.sGridMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var gc: TGridCoord; begin if Sender is TStringGrid then begin if TStringGridX(Sender).GridState in [gsRowMoving] then begin TStringGrid(Sender).MouseToCell(X, Y, gc.X, gc.Y); //here I know which lines you can go Caption := IntToStr(gc.X) + ':' + IntToStr(gc.Y); end; end; end; procedure TFormX.sGridRowMoved(Sender: TObject; FromIndex, ToIndex: Integer); begin //it also says which row to move to which row. //How can I cancel this operation if it is not the row I want. end; From the attached picture, Example 1-) I can move the A9 code on line 10 between lines 2 and 15. I want to prevent the move outside of these lines. Example 2-) F code in line 20 can be moved to lines 1, 16, 23, 27. I will also move F1 and F2 lines under this F code. When the move starts, I find the lines where the move can be done (1,16,23,27) what I really want it may seem like a complicated situation. How do I cancel only the line move job? How do I make it move over only the lines I want in the move? Thanks in advance.