source: trunk/Packages/CoolWeb/Persistence/SqlDatabase.pas

unit SqlDatabase;

// Modified: 2022-09-08

interface

uses
  SysUtils, Classes, Dialogs, mysql50, TypInfo, Generics, Generics.Collections;

type
  EQueryError = class(Exception);

  TClientCapabilities = (_CLIENT_LONG_PASSWORD, _CLIENT_FOUND_ROWS,
    _CLIENT_LONG_FLAG, _CLIENT_CONNECT_WITH_DB, _CLIENT_NO_SCHEMA,
    _CLIENT_COMPRESS, _CLIENT_ODBC, _CLIENT_LOCAL_FILES, _CLIENT_IGNORE_SPACE,
    _CLIENT_INTERACTIVE, _CLIENT_SSL, _CLIENT_IGNORE_SIGPIPE, _CLIENT_TRANSACTIONS);

  TSetClientCapabilities = set of TClientCapabilities;

  TLogEvent = procedure(Sender: TObject; Text: string) of object;

  TDbRows = class(TList<TDictionaryStringString>)
  private
    function GetData(Index: Integer): TDictionaryStringString;
    procedure SetData(Index: Integer; const Value: TDictionaryStringString);
  public
    property Data[Index: Integer]: TDictionaryStringString read GetData write SetData; default;
    destructor Destroy; override;
  end;

  { TSqlDatabase }

  TSqlDatabase = class(TComponent)
  private
    FEncoding: string;
    FHostName: string;
    FPassword: string;
    FPort: Word;
    FSession: PMYSQL;
    FConnected: Boolean;
    FDatabase: string;
    FUserName: string;
    FOnLogQuery: TLogEvent;
    procedure mySQLClient1ConnectError(Sender: TObject; Msg: String);
    function GetConnected: Boolean;
    function GetLastErrorMessage: string;
    function GetLastErrorNumber: Integer;
    function GetCharset: string;
    procedure SetConnected(const AValue: Boolean);
    procedure SetDatabase(const Value: string);
    procedure SetEncoding(AValue: string);
  public
    LastUsedTable: string;
    LastQuery: string;
    function EscapeString(Text: string): string;
    procedure CreateDatabase;
    procedure CreateTable(Name: string);
    procedure CreateColumn(Table, ColumnName: string; ColumnType: TTypeKind);
    procedure Query(DbRows: TDbRows; Data: string);
    procedure Select(DbRows: TDbRows; ATable: string; Filter: string = '*';
      Condition: string = '');
    procedure Delete(ATable: string; Condition: string = '';
      Schema: string = '');
    procedure Insert(ATable: string; Data: TDictionaryStringString;
      Schema: string = '');
    procedure Update(ATable: string; Data: TDictionaryStringString;
      Condition: string = ''; Schema: string = '');
    procedure Replace(ATable: string; Data: TDictionaryStringString;
      Schema: string = '');
    procedure Connect;
    procedure Disconnect;
    function LastInsertId: Integer;
    property LastErrorMessage: string read GetLastErrorMessage;
    property LastErrorNumber: Integer read GetLastErrorNumber;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Charset: string read GetCharset;
  published
    property Connected: Boolean read GetConnected write SetConnected;
    property Database: string read FDatabase write SetDatabase;
    property HostName: string read FHostName write FHostName;
    property UserName: string read FUserName write FUserName;
    property Password: string read FPassword write FPassword;
    property Port: Word read FPort write FPort;
    property Encoding: string read FEncoding write SetEncoding;
    property OnLogQuery: TLogEvent read FOnLogQuery write FOnLogQuery;
  end;

  function MySQLFloatToStr(F: Real): string;
  function MySQLStrToFloat(S: string): Real;
  function SQLToDateTime(Value: string): TDateTime;
  function DateTimeToSQL(Value: TDateTime): string;

procedure Register;


implementation

uses
  DateUtils;

resourcestring
  SDatabaseQueryError = 'Database query error: "%s"';

const
  CLIENT_LONG_PASSWORD = 1;      // new more secure passwords
  CLIENT_FOUND_ROWS = 2;         // Found instead of affected rows
  CLIENT_LONG_FLAG = 4;          // Get all column flags
  CLIENT_CONNECT_WITH_DB = 8;    // One can specify db on connect
  CLIENT_NO_SCHEMA = 16;         // Don't allow database.table.column
  CLIENT_COMPRESS = 32;          // Can use compression protcol
  CLIENT_ODBC = 64;              // Odbc client
  CLIENT_LOCAL_FILES = 128;      // Can use LOAD DATA LOCAL
  CLIENT_IGNORE_SPACE = 256;     // Ignore spaces before '('
  CLIENT_INTERACTIVE = 1024;     // This is an interactive client
  CLIENT_SSL = 2048;             // Switch to SSL after handshake
  CLIENT_IGNORE_SIGPIPE = 4096;  // IGNORE sigpipes
  CLIENT_TRANSACTIONS = 8192;    // Client knows about transactions

procedure Register;
begin
  RegisterComponents('CoolWeb', [TSqlDatabase]);
end;

function MySQLFloatToStr(F: Real): string;
var
  S: string;
begin
  S := FloatToStr(F);
  if Pos(',', S) > 0 then S[Pos(',', S)] := '.';
  Result := S;
end;

function MySQLStrToFloat(S: string): Real;
begin
  if Pos('.', S) > 0 then S[Pos('.', S)] := ',';
  Result := StrToFloat(S);
end;

function StrToStr(Value: string): string;
begin
  Result := Value;
end;

function SQLToDateTime(Value: string): TDateTime;
var
  Parts: TListString;
  DateParts: TListString;
  TimeParts: TListString;
begin
  try
    Parts := TListString.Create;
    DateParts := TListString.Create;
    TimeParts := TListString.Create;

    Parts.Explode(' ', Value);
    DateParts.Explode('-', Parts[0]);
    Result := EncodeDate(StrToInt(DateParts[0]), StrToInt(DateParts[1]),
      StrToInt(DateParts[2]));
    if Parts.Count > 1 then begin
      TimeParts.Explode(':', Parts[1]);
      Result := Result + EncodeTime(StrToInt(TimeParts[0]), StrToInt(TimeParts[1]),
        StrToInt(TimeParts[2]), 0);
    end;
  finally
    DateParts.Free;
    TimeParts.Free;
    Parts.Free;
  end;
end;

function DateTimeToSQL(Value: TDateTime): string;
begin
  Result := FormatDateTime('yyyy-mm-dd hh.nn.ss', Value);
end;

{ TSqlDatabase }

procedure TSqlDatabase.Connect;
var
  NewSession: PMYSQL;
  Rows: TDbRows;
begin
  FSession := mysql_init(FSession);
  NewSession := mysql_real_connect(FSession, PChar(HostName), PChar(UserName),
    PChar(Password), PChar(Database), FPort, nil, CLIENT_LONG_PASSWORD + CLIENT_CONNECT_WITH_DB);
  if Assigned(NewSession) then begin
    FConnected := True;
    FSession := NewSession;
  end else FConnected := False;

  if LastErrorNumber <> 0 then
    raise EQueryError.Create(Format(SDatabaseQueryError, [LastErrorMessage]));

  try
    Rows := TDbRows.Create;
    Query(Rows, 'SET NAMES ' + FEncoding);
  finally
    Rows.Free;
  end;
end;

procedure TSqlDatabase.Insert(ATable: string; Data: TDictionaryStringString;
  Schema: string);
var
  DbNames: string;
  DbValues: string;
  Value: string;
  DbResult: TDbRows;
  Item: TPair<string, string>;
begin
  LastUsedTable := ATable;
  DbNames := '';
  DbValues := '';
  for Item in Data do begin
    Value := Item.Value;
    StringReplace(Value, '"', '\"', [rfReplaceAll]);
    if Value = 'NOW()' then DbValues := DbValues + ',' + Value
    else DbValues := DbValues + ',"' + Value + '"';
    DbNames := DbNames + ',`' + Item.Key + '`';
  end;
  System.Delete(DbNames, 1, 1);
  System.Delete(DbValues, 1, 1);
  try
    DbResult := TDbRows.Create;
    if Schema <> '' then Schema := '`' + Schema + '`.';
    Query(DbResult, 'INSERT INTO ' + Schema + '`' + ATable + '` (' + DbNames + ') VALUES (' + DbValues + ')');
  finally
    DbResult.Free;
  end;
end;

procedure TSqlDatabase.Query(DbRows: TDbRows; Data: string);
var
  I, II: Integer;
  DbResult: PMYSQL_RES;
  DbRow: MYSQL_ROW;
begin
  DbRows.Clear;
  if Assigned(FOnLogQuery) then FOnLogQuery(Self, Data);
  LastQuery := Data;
  mysql_query(FSession, PChar(Data));
  if LastErrorNumber <> 0 then begin
    raise EQueryError.Create(Format(SDatabaseQueryError, [LastErrorMessage]));
  end;

  DbResult := mysql_store_result(FSession);
  try
    if Assigned(DbResult) then begin
      DbRows.Count := mysql_num_rows(DbResult);
      for I := 0 to DbRows.Count - 1 do begin
        DbRow := mysql_fetch_row(DbResult);
        DbRows[I] := TDictionaryStringString.Create;
        with DbRows[I] do begin
          for II := 0 to mysql_num_fields(DbResult) - 1 do begin
            Add(mysql_fetch_field_direct(DbResult, II)^.Name,
              PChar((DbRow + II)^));
          end;
        end;
      end;
    end;
  finally
    mysql_free_result(DbResult);
  end;
end;

procedure TSqlDatabase.Replace(ATable: string; Data: TDictionaryStringString;
  Schema: string = '');
var
  DbNames: string;
  DbValues: string;
  Value: string;
  DbResult: TDbRows;
  Item: TPair<string, string>;
begin
  LastUsedTable := ATable;
  DbNames := '';
  DbValues := '';
  for Item in Data do begin
    Value := Item.Value;
    StringReplace(Value, '"', '\"', [rfReplaceAll]);
    if Value = 'NOW()' then DbValues := DbValues + ',' + Value
    else DbValues := DbValues + ',"' + Value + '"';
    DbNames := DbNames + ',`' + Item.Key + '`';
  end;
  System.Delete(DbNames, 1, 1);
  System.Delete(DbValues, 1, 1);
  try
    DbResult := TDbRows.Create;
    if Schema <> '' then Schema := '`' + Schema + '`.';
    Query(DbResult, 'REPLACE INTO ' + Schema + '`' + ATable + '` (' + DbNames + ') VALUES (' + DbValues + ')');
  finally
    DbResult.Free;
  end;
end;

procedure TSqlDatabase.Select(DbRows: TDbRows; ATable: string; Filter: string = '*'; Condition: string = '');
var
  QueryText: string;
begin
  LastUsedTable := ATable;
  QueryText := 'SELECT ' + Filter + ' FROM `' + ATable + '`';
  if Condition <> '' then QueryText := QueryText + ' WHERE ' + Condition;
  Query(DbRows, QueryText);
end;

procedure TSqlDatabase.Update(ATable: string; Data: TDictionaryStringString;
  Condition: string = ''; Schema: string = '');
var
  QueryText: string;
  DbValues: string;
  Value: string;
  DbResult: TDbRows;
  Item: TPair<string, string>;
begin
  LastUsedTable := ATable;
  DbValues := '';
  for Item in Data do begin
    Value := Item.Value;
    StringReplace(Value, '"', '\"', [rfReplaceAll]);
    if Value = 'NOW()' then DbValues := DbValues + ',' + Value
    else DbValues := DbValues + ',`' + Item.Key + '` =' + '"' + Value + '"';
  end;
  System.Delete(DbValues, 1, 1);
  try
    DbResult := TDbRows.Create;
    if Schema <> '' then Schema := '`' + Schema + '`.';
    QueryText := 'UPDATE ' + Schema + '`' + ATable + '` SET ' + DbValues;
    if Condition <> '' then QueryText := QueryText + ' WHERE ' + Condition;
    Query(DbResult, QueryText);
  finally
    DbResult.Free;
  end;
end;

procedure TSqlDatabase.mySQLClient1ConnectError(Sender: TObject; Msg: String);
begin
//  LastError := Msg + '('+IntToStr(mySQLClient1.LastErrorNumber)+')';
end;

procedure TSqlDatabase.Delete(ATable: string; Condition: string = '';
  Schema: string = '');
var
  QueryText: string;
  DbResult: TDbRows;
begin
  LastUsedTable := ATable;
  try
    DbResult := TDbRows.Create;
    if Schema <> '' then Schema := '`' + Schema + '`.';
    QueryText := 'DELETE FROM ' + Schema + '`' + ATable + '`';
    if Condition <> '' then QueryText := QueryText + ' WHERE ' + Condition;
    Query(DbResult, QueryText);
  finally
    DbResult.Free;
  end;
end;

function TSqlDatabase.GetConnected: Boolean;
begin
  Result := FConnected;
end;

procedure TSqlDatabase.Disconnect;
begin
  mysql_close(FSession);
  FConnected := False;
end;

constructor TSqlDatabase.Create(AOwner: TComponent);
begin
  inherited;
  FSession := nil;
  Encoding := 'utf8';
  FPort := 3306;
end;

function TSqlDatabase.LastInsertId: Integer;
begin
  Result := mysql_insert_id(FSession);
end;

function TSqlDatabase.GetLastErrorMessage: string;
begin
  Result := mysql_error(FSession);
end;

function TSqlDatabase.GetLastErrorNumber: Integer;
begin
  Result := mysql_errno(FSession);
end;

procedure TSqlDatabase.CreateDatabase;
var
  TempDatabase: string;
  DbRows: TDbRows;
begin
  TempDatabase := Database;
  Database := 'mysql';
  Connect;
  try
    DbRows := TDbRows.Create;
    Query(DbRows, 'CREATE DATABASE ' + TempDatabase);
  finally
    DbRows.Free;
  end;
  Disconnect;
  Database := TempDatabase;
end;

procedure TSqlDatabase.CreateTable(Name: string);
var
  DbRows: TDbRows;
begin
  try
    DbRows := TDbRows.Create;
    Query(DbRows, 'CREATE TABLE `' + Name + '`' +
    ' (`Id` INT NOT NULL AUTO_INCREMENT, PRIMARY KEY (`Id`));');
  finally
    DbRows.Free;
  end;
end;

procedure TSqlDatabase.CreateColumn(Table, ColumnName: string;
  ColumnType: TTypeKind);
const
  ColTypes: array[0..17] of string = ('', 'INT', 'CHAR', 'INT', 'DOUBLE',
  'VARCHAR(255)', 'SET', 'INT', '', '', 'TEXT', 'TEXT', '', '', '', '', '', '');
var
  DbRows: TDbRows;
begin
  try
    DbRows := TDbRows.Create;
    Query(DbRows, 'ALTER TABLE `' + Table + '` ADD `' + ColumnName + '` ' +
      ColTypes[Integer(ColumnType)] + ' NOT NULL');
  finally
    DbRows.Free;
  end;
end;

destructor TSqlDatabase.Destroy;
begin
  if Connected then Disconnect;
end;

function TSqlDatabase.GetCharset: string;
begin
  Result := mysql_character_set_name(FSession);
end;

procedure TSqlDatabase.SetConnected(const AValue: Boolean);
begin
  if AValue = FConnected then Exit;
  if AValue then Connect
    else Disconnect;
end;

procedure TSqlDatabase.SetDatabase(const Value: string);
begin
  FDatabase := Value;
  if FConnected then mysql_select_db(FSession, PChar(FDatabase));
end;

procedure TSqlDatabase.SetEncoding(AValue: string);
var
  Rows: TDbRows;
begin
  if FEncoding = AValue then Exit;
  FEncoding := AValue;
  if Connected then begin
    try
      Rows := TDbRows.Create;
      Query(Rows, 'SET NAMES ' + FEncoding);
    finally
      Rows.Free;
    end;
  end;
end;

function TSqlDatabase.EscapeString(Text: string): string;
var
  L: Integer;
begin
  SetLength(Result, Length(Text) * 2 + 1);
  L := mysql_real_escape_string(FSession, PChar(Result), PChar(Text), Length(Text));
  SetLength(Result, L);
end;

{ TDbRows }

destructor TDbRows.Destroy;
begin
  inherited;
end;

function TDbRows.GetData(Index: Integer): TDictionaryStringString;
begin
  Result := TDictionaryStringString(Items[Index]);
end;

procedure TDbRows.SetData(Index: Integer; const Value: TDictionaryStringString);
begin
  Items[Index] := Value;
end;

end.