unit dmMain;

// this code is under the BAF fair use license (BFUL) - https://bafbal.de/index.php?title=Bful
// main database connection

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, System.IniFiles,
  uBafTypes, Winapi.ShellAPI, Winapi.ActiveX, Winapi.ShlObj, Data.DB,
  uStringIniFile, uBafComboHelper, UniProvider, SQLiteUniProvider, MemDS,
  DBAccess, Uni, InterBaseUniProvider, PostgreSQLUniProvider, MySQLUniProvider,
  LiteDataTypeMapUni, IBCDataTypeMapUni, ZohoCRMUniProvider,
  SugarCRMUniProvider, SalesforceMCUniProvider, SalesforceUniProvider,
  QuickBooksUniProvider, NetSuiteUniProvider, MailChimpUniProvider,
  MagentoUniProvider, DynamicsCRMUniProvider, BigCommerceUniProvider,
  SQLServerUniProvider, RedshiftUniProvider, OracleUniProvider,
  MongoDBUniProvider, DBFUniProvider, DB2UniProvider, CRVio,
  ASEUniProvider, AdvantageUniProvider, ODBCUniProvider, AccessUniProvider,
  FireDAC.Stan.Intf, FireDAC.Stan.Option, FireDAC.Stan.Error, FireDAC.UI.Intf,
  FireDAC.Phys.Intf, FireDAC.Stan.Def, FireDAC.Stan.Pool, FireDAC.Stan.Async,
  FireDAC.Phys, FireDAC.FMXUI.Wait, FireDAC.Comp.Client, contnrs,
  System.SyncObjs, Winapi.Windows;

const
  CAT_SETTS = 'Settings';
  CAT_LOG = 'Log';
  CAT_USRDATA = 'Userdata';
  CAT_LANGUAGE = 'Language';
  CAT_DATA = 'Data';
  CAT_SYS = 'SYS';
  CAT_CODE = 'Code';
  CAT_MIG = 'Migration';
  CAT_MIGC = 'Migration Compare';
  CAT_FRM = 'FRM';
  CAT_MENU = 'Menu';
  CAT_HIST = 'Hist';
  CAT_DEBUG = 'Debug';
  CAT_DEBUG_DB = 'Debug DB';
  CAT_DEBUG_NODE = 'Debug Node';

  QEN_UPSERT = 'intern upsert';
  QEN_DATAMEMO = 'data_memo';
  QEN_COMMAND = 'command';
  QEN_HISTORY = 'history';

  IS_FIRE_DAC = true;
  DC_DEFAULT = 'default';
  DC_MIG = 'migration';



type
  TBafQueryType = (qtMain, qtLog);

  TUpsert2KeyValue = (ukvGuid, ukvValue, ukvNull, ukv0);

  TUserData = class
    user_user_id: string;
    shortname: string;
    firstname: string;
    lastname: string;
    userid: string;
    tel: string;
    email: string;
  end;

  TBafDbCon = class;

  TBafParams = class
  private
    FQuery: TUniQuery;
    FBafDbCon: TBafDbCon;
  public
    destructor Destroy; override;
    procedure ParamAsString(const AParamName, AValue: string; AOraClob: boolean = false); overload;
    procedure ParamAsString(AIndex: integer; AValue: string; AOraClob: boolean = false); overload;
    procedure ParamAsDateTime(const AParamName: string; AValue: TDateTime); overload;
    procedure ParamAsDateTime(AIndex: integer; AValue: TDateTime); overload;
    procedure ParamAsCurrency(const AParamName: string; AValue: currency); overload;
    procedure ParamAsCurrency(AIndex: integer; AValue: currency); overload;
    procedure ParamAsInteger(const AParamName: string; AValue: integer); overload;
    procedure ParamAsInteger(AIndex: integer; AValue: integer); overload;
    procedure ParamAsFloat(const AParamName: string; AValue: double); overload;
    procedure ParamAsFloat(AIndex: integer; AValue: double); overload;
    procedure ParamNull(const AParamName: string); overload;
    procedure ParamNull(AIndex: integer); overload;
    function Count: integer;
    function GetParamName(AIndex: integer): string;
    function GetParamNameAndValue(AIndex: integer): string;
    procedure SetValue(AIndex: integer; AValue: string);
    property Query: TUniQuery read FQuery write FQuery;
    property BafDbCon: TBafDbCon read FBafDbCon write FBafDbCon;
  end;

  TBafThreadCon = class
  private
    FActive: boolean;
    FIx: integer;
  protected
    FConnection: TUniConnection;
    FTransaction: TUniTransaction;
    FParams: TBafParams;
    FDriverName: string;
  public
    constructor Create;
    destructor Destroy; override;
    procedure ConnectDatabase(ADbName, ADriverName: string);
    property Active: boolean read FActive write FActive;
    property Ix: integer read FIx;
    property DriverName: string read FDriverName write FDriverName;
  end;

  TBafDbCon = class
  private
    FBafGen: TBafGeneration;
    FCommandTableId: string;
    FIdExt: string;
    FCommandTableHist: string;
    FCommandTable: string;
    FHistExt: string;
    FProgChg: string;
    FDriverName: string;
    FDbName: string;
  protected
    FConnection: TUniConnection;
    FTransaction: TUniTransaction;
    FLogTransaction: TUniTransaction;
    FFieldDefs: TStringList;
    FIoHandler: TCRIOHandler;
  protected
    FLock: TCriticalSection;
    FThreadConList: TObjectList;
  public
    constructor Create;
    destructor Destroy; override;
    function GetQuery(AName: string; AType: TBafQueryType = qtMain): TBafParams;
    function AcquireThreadCon: TBafThreadCon;
    function GetThreadCon(AIx: integer): TBafThreadCon;
    procedure RemoveQuery(AName: string);
    procedure InitLog;
    property BafGen: TBafGeneration read FBafGen write FBafGen;
    property CommandTable: string read FCommandTable;
    property CommandTableId: string read FCommandTableId;
    property CommandTableHist: string read FCommandTableHist;
    property HistExt: string read FHistExt;
    property IdExt: string read FIdExt;
    property ProgChg: string read FProgChg;
    property DriverName: string read FDriverName write FDriverName;
    property DbName: string read FDbName write FDbName;
  end;

  TdataMain = class(TForm)
    UniQuery1: TUniQuery;
    SQLiteUniProvider1: TSQLiteUniProvider;
    conTest: TUniConnection;
    InterBaseUniProvider1: TInterBaseUniProvider;
    PostgreSQLUniProvider1: TPostgreSQLUniProvider;
    MySQLUniProvider1: TMySQLUniProvider;
    AccessUniProvider1: TAccessUniProvider;
    AdvantageUniProvider1: TAdvantageUniProvider;
    ASEUniProvider1: TASEUniProvider;
    DB2UniProvider1: TDB2UniProvider;
    DBFUniProvider1: TDBFUniProvider;
    MongoDBUniProvider1: TMongoDBUniProvider;
    ODBCUniProvider1: TODBCUniProvider;
    OracleUniProvider1: TOracleUniProvider;
    RedshiftUniProvider1: TRedshiftUniProvider;
    SQLServerUniProvider1: TSQLServerUniProvider;
    BigCommerceUniProvider1: TBigCommerceUniProvider;
    DynamicsCRMUniProvider1: TDynamicsCRMUniProvider;
    MagentoUniProvider1: TMagentoUniProvider;
    MailChimpUniProvider1: TMailChimpUniProvider;
    NetSuiteUniProvider1: TNetSuiteUniProvider;
    QuickBooksUniProvider1: TQuickBooksUniProvider;
    SalesforceUniProvider1: TSalesforceUniProvider;
    SalesforceMCUniProvider1: TSalesforceMCUniProvider;
    SugarCRMUniProvider1: TSugarCRMUniProvider;
    ZohoCRMUniProvider1: TZohoCRMUniProvider;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ConnectDatabase(ACon: TUniConnection; ADbName, ADriverName: string);
    procedure ConnectDatabaseDataTypes(ACon: TUniConnection; ADriverName: string);
    procedure CreateInter;
  protected
    FIni: TStringIniFile;
    FRoot: string;
    FUserGuid: string;
    FUserIni: TStringIniFile;
    FUserRoot: string;
    FProgName: string;
    FRightUserId: string;
    FUserData: TUserData;
    FRightUserData: TUserData;
    FSysEng: boolean;
    FDbName: string;
    FDriver: string;
    procedure InitDBClient;
    procedure InitDbSrvProc;
    procedure CheckPassword;
  protected  // Queries, Params
    function CheckDebugUpsert(AIni: TStringIniFile): boolean;
    function CheckDebugExec(ASql: string; AParams: TBafParams): boolean;
    function CheckDebugSelect(AParams: TBafParams; ACmd: boolean = false): boolean;
  private
    FDefaultMaxRows: integer;
    FUserId: string;
    FDefaultCon: TBafDbCon;
    FMigCon: TBafDbCon;
    FTableNameSrv: string;
    FTableNameLogLine: string;
    FTableNameLog: string;
  protected  // FieldDefs
    function GetTableFieldDefs(ABafConName, ATableName: string): TStringList;
  protected
    FDbConnectionList: TStringList;
    procedure ConnectAdditionalDB;
  public
    procedure Init;
    function WriteCommand(ABafConName, AId, AName, ACode, AParent: string;
        AMode: char; var ADateChg: TDateTime): boolean;
    function ReplaceSqlFunction(AText: string): string;
    function GetSpecialFolder(aFolder: Integer): string;
    function GetDefaultUserIdent: string;
    function GetUserInfo(AName, AParam: string): string;
    // Gets the command from the DB
    function GetCommand(AName: string; ACode: TStrings): boolean;
    // the root dir of the application
    property Root: string read FRoot;
    // the documents dir
    property UserRoot: string read FUserRoot;
    // the logged in user
    property UserGuid: string read FUserGuid;
    // the customer id of the logged in user
    property UserId: string read FUserId;
    // the user whose rights are used
    property RightUserId: string read FRightUserId write FRightUserId;
    // the ini of the system
    property Ini: TStringIniFile read FIni;
    // the ini of the user settings
    property UserIni: TStringIniFile read FUserIni;
    // the maximum of data loaded per default
    property DefaultMaxRows: integer read FDefaultMaxRows write FDefaultMaxRows;
  public // SYS
    function LoadDataMemo(AItem, ARef: string; var AId, AText: string): boolean;
    function GetDataMemoHistTable(var ATableName, AKeyName: string): boolean;
    procedure SaveDataMemo(AItem, ARef, AId, AText, AFunctionName: string);
    function SetMigrationDB(AIndex: integer; var ADriverName: string): string;
    property ProgName: string read FProgName;
    property DBName: string read FDBName;
    property SysEng: boolean read FSysEng write FSysEng;
    property Driver: string read FDriver;
    property TableNameSrv: string read FTableNameSrv;
    property TableNameLog: string read FTableNameLog;
    property TableNameLogLine: string read FTableNameLogLine;
  public // Datasets
    function GetBafDbCon(ABafConName: string): TBafDbCon;
    function QueryPrepare(ABafConName, AName, ASql: string;
        AType: TBafQueryType = qtMain): TBafParams; overload;
    function QueryPrepare(AAddDb: TBafDbCon; AName, ASql: string;
        AType: TBafQueryType = qtMain): TBafParams; overload;
    function QueryExecute(ABafConName, AName: string): integer; overload;
    function QueryExecute(AAddDb: TBafDbCon; AName: string): integer; overload;
    function QueryOpen(ABafConName, AName: string;
        ACmd: boolean = false): TDataset; overload;
    function QueryOpen(AAddDb: TBafDbCon; AName: string;
        ACmd: boolean = false): TDataset; overload;
    function QueryData(ABafConName, AName: string): TDataset; overload;
    function QueryData(AAddDb: TBafDbCon; AName: string): TDataset; overload;
    function QueryData(AName: string): TDataset; overload;
    procedure QueryClose(ABafConName, AName: string); overload;
    procedure QueryClose(AAddDb: TBafDbCon; AName: string); overload;
    procedure ColumnNames(ABafConName, ATableName: string; AColumns: TStrings);
    procedure UpsertIni(AIni: TStringIniFile; ABafConName, AProg: string;
        var ARowAffected: integer; AMultiLineFields: TStringList = nil);
    procedure UpsertIni2(AIni: TStringIniFile; ABafConName, AProg, ASql: string;
        var ARowAffected: integer; var AKeyValue: string;
        AUpsert2KeyValue: TUpsert2KeyValue; AMultiLineFields: TStringList = nil);
    procedure StartTransaction(ABafConName: string);
    procedure Commit(ABafConName: string);
    procedure Rollback(ABafConName: string);
    function CanTransactions(ABafConName: string): boolean;
    function CanTransaction(ABafConName: string): boolean;
    procedure Sync2Desc(ATableName, AKeyName, AWhere: string);
    function ColumnConvert(ATableName, AKeyName, AColumnName: string;
        AConvert: integer): integer;
    function GetHistSqlStatement(ABafConName, ATableName, AKeyName, AKeyValue: string): string;
    procedure GetTables(ABafConName: string; AList: TStrings);
    procedure DbAdditionalConnect(AName, ADbName: string);
    function AddLimit(ABafConName: string; AValue: integer): string;
    function GetLimitedSelect(ABafConName, ATableName: string; AValue: integer): string;
    property DefaultCon: TBafDbCon read FDefaultCon;
    property MigCon: TBafDbCon read FMigCon;
    property GetDbConnectionList: TStringList read FDbConnectionList;
  public // Threads
    function ThreadQueryPrepare(ABafConName, ASql: string;
        var AConPoolIx: integer): TBafParams;
    function ThreadQueryOpen(ABafConName: string; AConPoolIx: integer): TDataset;
    procedure ThreadQueryClose(ABafConName: string; AConPoolIx: integer);
  public // Lookup and Specials
    procedure RefreshLookup(AName: string; AHelper: TBafComboHelper);
    procedure RefreshSpecial(AName: string; AHelper: TBafComboHelper);
    function GetSqlTextFromDevtext(AName, ADriverName: string): string;
    function GetFieldDef(ABafConName, ATableName, AFieldName: string): Char;
  end;

var
  dataMain: TdataMain;
  gvInterType: TBafInterType;
  gvStart: integer;
  gvStartText: string;
  mvQueryList: TStringList;

implementation

{$R *.fmx}

uses foMain, foBafDbDebug, uBafTranslationModule, foLogin, uBafDataCache,
  udataHistSql, uBafCrypt, uBafInterpreter, uBafInterpreterModuleList,
  foBafMigration, foBafCode, uOsStuff, dmWD;

var
  mvInterpreter: TBafInterpreter;


function TdataMain.AddLimit(ABafConName: string; AValue: integer): string;
begin
  result := '';
  if AnsiCompareText(GetBafDbCon(ABafConName).DriverName, 'Postgres') = 0 then
    result := ' limit ' + IntToStr(AValue);
end;

function TdataMain.CanTransaction(ABafConName: string): boolean;
var
  LAddDb: TBafDbCon;
begin
  LAddDb := GetBafDbCon(ABafConName);
  result := CanTransactions(ABafConName) and not LAddDb.FTransaction.Active;
end;

function TdataMain.CanTransactions(ABafConName: string): boolean;
begin
  result := true;
end;

function TdataMain.CheckDebugExec(ASql: string; AParams: TBafParams): boolean;
var
  i: integer;
begin
  result := true;
  if gvInterType = itClient then begin
    if frmMain.cbExec.IsChecked then begin
      frmBafDbDebug.cbLog.Text := 'Debug Exec';
      frmBafDbDebug.cbLog.IsChecked := true;
      frmBafDbDebug.memLog.Lines.Text := ASql;
      frmBafDbDebug.memLog.Lines.Add('');
      frmBafDbDebug.memLog.Lines.Add('---------------------------------------------------');
      for i := 0 to AParams.Count - 1 do
        frmBafDbDebug.memLog.Lines.Add(AParams.GetParamNameAndValue(i));

      result := (frmBafDbDebug.ShowModal = mrOk);

      frmMain.cbExec.IsChecked := frmBafDbDebug.cbLog.IsChecked;
    end;
  end;
end;

function TdataMain.CheckDebugSelect(AParams: TBafParams; ACmd: boolean = false): boolean;
var
  i: integer;
begin
  result := true;
  if Assigned(frmMain) and frmMain.cbSelect.IsChecked
      and not ACmd then begin
    frmBafDbDebug.cbLog.Text := 'Debug Select';
    frmBafDbDebug.cbLog.IsChecked := true;
    frmBafDbDebug.memLog.Lines.Text := AParams.Query.Sql.Text;
    frmBafDbDebug.memLog.Lines.Add('');
    frmBafDbDebug.memLog.Lines.Add('---------------------------------------------------');
    for i := 0 to AParams.Count - 1 do
      frmBafDbDebug.memLog.Lines.Add(AParams.GetParamNameAndValue(i));

    result := (frmBafDbDebug.ShowModal = mrOk);

    frmMain.cbSelect.IsChecked := frmBafDbDebug.cbLog.IsChecked;
  end;
end;

function TdataMain.CheckDebugUpsert(AIni: TStringIniFile): boolean;
begin
  result := true;
  if Assigned(frmMain) and frmMain.cbUpsert.IsChecked
      and (gvInterType = itClient) then begin
    frmBafDbDebug.cbLog.Text := 'Debug Upsert';
    frmBafDbDebug.cbLog.IsChecked := true;
    frmBafDbDebug.memLog.Lines.Text := AIni.AsString;

    result := (frmBafDbDebug.ShowModal = mrOk);

    frmMain.cbUpsert.IsChecked := frmBafDbDebug.cbLog.IsChecked;
  end;
end;

procedure TdataMain.CheckPassword;
var
  LSql: string;
  LParams: TBafParams;
  LDataset: TDataSet;
  b: boolean;
begin
  CreateInter;
  case DefaultCon.BafGen of
    bg303TT: LSql := 'select user_user_id, null as shortname, vorname as firstname, nachname as lastname, userid, '
      + ' telefon as tel, email from neuland.user_user where login = :lo '
      + ' and cpassword = :pw and status = 1 ';
    bg303: LSql := 'select user_user_id, shortname, firstname, lastname, userid, '
      + ' tel, email from user_user where login = :lo '
      + ' and cpassword = :pw and status = 1 ';
  else
    LSql := 'select user_user_id, shortname, firstname, lastname, userid, tel, '
      +' email from user_user where login = :lo '
      + ' and cpassword = :pw and status = ''1'' ';
  end;
  b := true;
  while b = true do begin
    LParams := QueryPrepare(DefaultCon, 'pw', LSql);
    LParams.ParamAsString('lo', gvUsername);
    LParams.ParamAsString('pw', gvPasswordHash);
    LDataset := QueryOpen(DefaultCon, 'pw');
    FUserGuid := LDataset.FieldByName('user_user_id').AsString;
    FUserId :=  LDataset.FieldByName('userid').AsString;
    FUserData:= TUserData.Create;
    FUserData.user_user_id := LDataset.FieldByName('user_user_id').AsString;
    FUserData.userid := LDataset.FieldByName('userid').AsString;
    FUserData.firstname := LDataset.FieldByName('firstname').AsString;
    FUserData.lastname := LDataset.FieldByName('lastname').AsString;
    FUserData.tel := LDataset.FieldByName('tel').AsString;
    FUserData.email := LDataset.FieldByName('email').AsString;
    FUserData.shortname := LDataset.FieldByName('shortname').AsString;
    if FUserGuid = '' then begin
      ShowMessage('Login incorrect');
      if not TfrmLogin.Login then begin
        b := false;
        Application.Terminate;
      end;
    end
    else b := false;
  end; // while b = true
  QueryClose(DefaultCon, 'pw');
  gvStart := 1250;
  gvBafDataCache.RefreshUserGroups(FUserGuid);
end;

function TdataMain.ColumnConvert(ATableName, AKeyName, AColumnName: string;
  AConvert: integer): integer;
var
  LDataSet: TDataSet;
  LSql: string;

  procedure lokDate1;
  // TDateTime -> yyyy-mm-dd hh:mm:ss
  var
    LDate: TDateTime;
    LParams: TBafParams;
  begin
    LDate := StrToDateTimeDef(LDataSet.Fields[1].AsString, -42.1337);
    if Abs(LDate + 42.1337) > 0.01 then begin
      LSql := Format('update %s set %s = :val where %s = :key',
          [ATableName, AColumnName, AKeyName]);
      LParams := QueryPrepare(DefaultCon, 'ColumnConvertUpdate', LSql);
      LParams.ParamAsString('val', FormatDateTime('yyyy-mm-dd hh:mm:ss', LDate));
      LParams.ParamAsString('key', LDataSet.Fields[0].AsString);
      QueryExecute(DefaultCon, 'ColumnConvertUpdate');
      inc(result);
    end;
  end; // procedure lokDate1

begin
  result := 0;
  LSql := Format('select %s, %s from %s', [AKeyName, AColumnName, ATableName]);
  QueryPrepare(DefaultCon, 'ColumnConvert', LSql);
  LDataSet := QueryOpen(DefaultCon, 'ColumnConvert');
  while not LDataSet.Eof do begin
    case AConvert of
      0: lokDate1; // TDateTime -> yyyy-mm-dd hh:mm:ss



    end;
    LDataSet.Next;
  end;
end;

procedure TdataMain.ColumnNames(ABafConName, ATableName: string; AColumns: TStrings);
var
  LSql: string;
  LDataSet: TDataSet;
  i: integer;
begin
  LSql := 'select * from ' + ATableName + ' where 1 = 0';
  QueryPrepare(ABafConName, 'ColumnNames', LSql);
  LDataSet := QueryOpen(ABafConName, 'ColumnNames');
  AColumns.Clear;
  for i := 0 to LDataSet.Fields.Count - 1 do
    AColumns.Add(AnsiLowerCase(LDataSet.Fields[i].FieldName));
  QueryClose(ABafConName, 'ColumnNames');
end;

procedure TdataMain.Commit(ABafConName: string);
var
  LAddDb: TBafDbCon;
begin
  LAddDb := GetBafDbCon(ABafConName);
  if CanTransactions(ABafConName) then
    LAddDb.FTransaction.Commit;
end;

procedure TdataMain.ConnectAdditionalDB;
var
  cnt, i: integer;
  LName, s, LDbName, LDriver: string;
  LBafDbCon: TBafDbCon;
begin
  cnt := FIni.ReadInteger(FDbName, 'adb_count', 0);
  for i := 1 to cnt do begin
    s := IntToStr(i);
    if FIni.ReadBoolJN(FDbName, 'adb_' + s + 'a', false) then begin
      LName := AnsiLowerCase(FIni.ReadString(FDbName, 'adb_' + s + 'n', ''));
      LDbName := FIni.ReadString(FDbName, 'adb_' + s, '');
      DbAdditionalConnect(LName, LDbName);
    end;
  end;
// procedure TdataMain.ConnectAdditionalDB
end;

procedure TdataMain.ConnectDatabase(ACon: TUniConnection;
    ADbName, ADriverName: string);
var
  LFileName, LDir, s, s2: string;
  i: integer;
begin
  ACon.Connected := false;
  ACon.ProviderName := FIni.ReadString(ADbName, 'uProviderName', '');
  s := FIni.ReadString(ADbName, 'uServer', '');
  s2 := FIni.ReadString(ADbName, 'uServer2', '');
  if (s2 <> '') and (random(2) mod 2 = 1) then
    s := s2;
  ACon.Server := s;
  LFileName := FIni.ReadString(ADbName, 'Database', '');
  LDir := ExtractFilePath(LFileName);
  if (LDir = '')
      and (AnsiCompareStr(ACon.Server, 'localhost') = 0)
      and (AnsiCompareText(ACon.ProviderName, 'PostgreSQL') <> 0)
      and (AnsiCompareText(ACon.ProviderName, 'MySQL') <> 0) then
    LFileName := IncludeTrailingPathDelimiter(FRoot) + LFileName;
  ACon.Database := LFileName;
  ACon.UserName := FIni.ReadString(ADbName, 'User', '');
  ACon.Password := BafDecrypt(FIni.ReadString(ADbName, 'Password', ''));
  for i := 1 to 12 do begin
    s := FIni.ReadString(ADbName, 'so' + IntToStr(i), '');
    if s <> '' then
      ACon.SpecificOptions.Add(s);
  end;
  ConnectDatabaseDataTypes(ACon, ADriverName);
  ACon.Connected := true;
end;

procedure TdataMain.ConnectDatabaseDataTypes(ACon: TUniConnection;
  ADriverName: string);
begin
  if ADriverName = 'sqlite' then
    ACon.DataTypeMap.AddDBTypeRule(liteDate, ftDateTime);
//  if ADriverName = 'firebird' then
//    ACon.DataTypeMap.AddDBTypeRule(ibcDate, ftDateTime);

  ;
end;

procedure TdataMain.CreateInter;
begin
  mvInterpreter := TBafInterpreter.Create(itSrvProc);
  mvInterpreter.Inter := mvInterpreter;
  mvInterpreter.Name := 'dmMain';

  TBafInterpreterModuleList.CreateModule(mvInterpreter);
end;

procedure TdataMain.DbAdditionalConnect(AName, ADbName: string);
var
  LDriver: string;
  LBafDbCon: TBafDbCon;
begin
  if (AName <> '') and (ADbName <> '') and (AName <> DC_DEFAULT) then begin
    LDriver := AnsiLowerCase(FIni.ReadString(ADbName, 'DriverName', ''));
    LBafDbCon := TBafDbCon.Create;
    try
      LBafDbCon.DriverName := LDriver;
      LBafDbCon.DbName := ADbName;
      LBafDbCon.BafGen := GetBafGeneration(FIni.ReadString(ADbName, 'BG', ''));
      ConnectDatabase(LBafDbCon.FConnection, ADbName, LDriver);
    except
      on E: Exception do
        ShowMessage('Error connecting ' + AName + #13#10 + E.Message);
    end;
    FDbConnectionList.AddObject(AName, LBafDbCon);
  end;
end;

procedure TdataMain.FormCreate(Sender: TObject);
begin
  FDbConnectionList := TStringList.Create;
  FDbConnectionList.Sorted := true;
  FDbConnectionList.Duplicates := dupError;
  FDbConnectionList.OwnsObjects := true;
end;

procedure TdataMain.FormDestroy(Sender: TObject);
begin
  FreeAndNil(mvInterpreter);
  FreeAndNil(FDbConnectionList);
end;

function TdataMain.GetBafDbCon(ABafConName: string): TBafDbCon;
var
  ix: integer;
begin
  result := nil;
  if ABafConName = '' then
    ABafConName := 'Default';
  ix := FDbConnectionList.IndexOf(AnsiLowerCase(ABafConName));
  if ix >= 0 then
    result := (FDbConnectionList.Objects[ix] as TBafDbCon);
end;

function TdataMain.GetCommand(AName: string; ACode: TStrings): boolean;
var
  LSql: string;
  LParams: TBafParams;
  LDataSet: TDataSet;
begin
  result := false;
  if AName = 'xlive' then begin
    ACode.Add('#frm  c="xlive - live execution of BAL commands"  y=live');
    result := true;
  end
  else begin
    LSql := Format('select code from %s where name = :name',
      [DefaultCon.CommandTable]);
    LParams := QueryPrepare(DefaultCon, QEN_COMMAND, LSql);
    LParams.ParamAsString('name', AName);
    LDataSet := QueryOpen(DefaultCon, QEN_COMMAND, true);
    if not LDataSet.Eof then begin
      ACode.Text := LDataSet.FieldByName('code').AsString;
      result := true;
    end
    else
      ACode.Clear;
    LDataSet.Close;
  end;
end;

function TdataMain.GetDataMemoHistTable(var ATableName, AKeyName: string): boolean;
begin
  case DefaultCon.BafGen of
    bg303TT: ATAbleName := 'neuland.data_memo';
  else
    ATAbleName := 'data_memo';
  end;

  AKeyName := 'data_memo_id';
  result := true;
end;

function TdataMain.GetDefaultUserIdent: string;
var
  LBafGen: TBafGeneration;
begin
  LBafGen := DefaultCon.BafGen;
  if LBafGen in [bg303TT] then
    result := UserId
  else
    result := UserGuid;
end;

function TdataMain.GetFieldDef(ABafConName, ATableName, AFieldName: string): Char;
var
  LFieldDef: TStringList;
  s: string;
begin
  LFieldDef := GetTableFieldDefs(ABafConName, ATableName);
  s := LFieldDef.Values[AnsiLowerCase(AFieldName)] + 'S';
  result := s[1];
end;

function TdataMain.GetHistSqlStatement(ABafConName, ATableName, AKeyName,
    AKeyValue: string): string;
var
  LText, LSql: string;
  LDataSet: TDataSet;
begin
  try
    LSql := Format('select d1.ctext, d2.ctext as text2   from sys_devtext d1 '
      + ' left outer join sys_devtext d2 on d2.parent = d1.sys_devtext_id and d2.name = ''%s'' '
      + ' where d1.name = ''_history'' ', [ABafConName]);
    QueryPrepare(DefaultCon, QEN_HISTORY, LSql);
    LDataSet := QueryOpen(DefaultCon, QEN_HISTORY);
    if not LDataSet.Eof then begin
      LText := LDataSet.FieldByName('text2').AsString;
      if LText = '' then
        LText := LDataSet.FieldByName('ctext').AsString;
    end;
  except

  end;

  if LText = '' then begin
    case GetBafDbCon(ABafConName).BafGen of
      bg303TT: LText := 'select u.bezeichnung as baf_shortname, '
            + 'h.datechg as baf_datechg, '
            + 'h.* from %s_hist h '
            + 'left outer join neuland.user_user u '
            + 'on to_char(u.user_user_id) = to_char(h.usrchg) '
            + '    or to_char(u.userid) = to_char(h.usrchg) '
            + 'where h.%s =  ''%s'' '
            + 'order by h.datechg desc';

      else
        LText := 'select u.shortname as baf_shortname, '
            + 'h.datechg as baf_datechg, '
            + 'h.* from %s_hist h '
            + 'left outer join user_user u on u.user_user_id = h.usrchg '
            + 'where h.%s =  ''%s'' '
            + 'order by h.datechg desc';
    end;
  end;
  result := Format(LText, [ATableName, AKeyName, AKeyValue]);
end;

function TdataMain.GetLimitedSelect(ABafConName, ATableName: string;
  AValue: integer): string;
var
  LDriverName: string;
begin
  result := '';
  LDriverName := GetBafDbCon(ABafConName).DriverName;
  if AnsiCompareText(LDriverName, 'Postgres') = 0 then
    result := Format('select * from %s limit %d', [ATableName, AValue])
  else if AnsiCompareText(LDriverName, 'MSSQL') = 0 then
    result := Format('select top %d * from %s', [AValue, ATableName])
  else
    result := Format('select * from %s', [ATableName]);
end;

function TdataMain.GetSpecialFolder(aFolder: Integer): string;
var
  pIdL: PItemIDList;
  Path: array [0..1023] of Char;
  Allocator: IMalloc;
begin
  SHGetSpecialFolderLocation (0, aFolder, pIdL);
  SHGetPathFromIDList (pIDL, Path);
  if Succeeded (SHGetMalloc (Allocator)) then
    Allocator.Free (pIdL);
  result := Path;
end;

function TdataMain.GetSqlTextFromDevtext(AName, ADriverName: string): string;
var
  LSql: string;
  LDataSet: TDataSet;
  LParams: TBafParams;
begin
  result := '';
  if ADriverName = '' then
    ADriverName := dataMain.Driver
  else
    ADriverName := AnsiLowerCase(ADriverName);
  AName := AnsiLowerCase(AName);
  case FDefaultCon.BafGen of
    bg303TT:
      LSql := 'select d.ctext as dext, t.ctext     from neuland.sys_devtext t '
          + ' left outer join neuland.sys_devtext d on d.parent = t.sys_devtext_id '
          + 'and lower(d.name) = :kdriver    where lower(t.name) = :kname  ';
    else
      LSql := 'select d.ctext as dext, t.ctext     from sys_devtext t '
          + ' left outer join sys_devtext d on d.parent = t.sys_devtext_id '
          + 'and lower(d.name) = :kdriver    where lower(t.name) = :kname  ';
  end;
  LParams := dataMain.QueryPrepare(DefaultCon, 'SqlDevtext', LSql);
  LParams.ParamAsString('kdriver', ADriverName);
  LParams.ParamAsString('kname', AName);
  LDataSet := dataMain.QueryOpen(DefaultCon, 'SqlDevtext');
  if not LDataSet.Eof then begin
    result := LDataSet.FieldByName('dext').AsString;
    if result = '' then
      result := LDataSet.FieldByName('ctext').AsString;
  end;
  result := ReplaceSqlFunction(result);
end;

function TdataMain.GetTableFieldDefs(ABafConName, ATableName: string): TStringList;
var
  LSql, s: string;
  LIndex, i: integer;
  LDataSet: TDataSet;
  sl: TStringList;
  LFieldDefs: TStringList;
begin
  ATableName := AnsiLowerCase(ATableName);
  LFieldDefs := GetBafDbCon(ABafConName).FFieldDefs;
  LIndex := LFieldDefs.IndexOf(ATableName);
  if LIndex = -1 then begin      // we don't know the table and query
    sl := TStringList.Create;
    LSql := Format('select * from %s where 0 = 1', [ATableName]);
    QueryPrepare(ABafConName, '#intern FieldDefs', LSql);
    LDataSet := QueryOpen(ABafConName, '#intern FieldDefs');
    for i := 0 to LDataSet.FieldCount - 1 do begin
      case LDataSet.Fields[i].DataType of
          ftCurrency: s := AnsiLowerCase(LDataSet.Fields[i].FieldName) + '=C';
          ftDate, ftDateTime:
              s := AnsiLowerCase(LDataSet.Fields[i].FieldName) + '=D';
          ftFloat: s := AnsiLowerCase(LDataSet.Fields[i].FieldName) + '=F';
          ftInteger: s := AnsiLowerCase(LDataSet.Fields[i].FieldName) + '=I';
        else
          s := AnsiLowerCase(LDataSet.Fields[i].FieldName) + '=S';
      end;
      sl.Add(s);
    end; // for i
    LIndex := LFieldDefs.AddObject(ATableName, sl);
  end;
  result := LFieldDefs.Objects[LIndex] as TStringList;
end;

procedure TdataMain.GetTables(ABafConName: string; AList: TStrings);
begin
  GetBafDbCon(ABafConName).FConnection.GetTableNames(AList);
  BafListSort(AList);
end;

function TdataMain.GetUserInfo(AName, AParam: string): string;
var
  LUserData: TUserData;
begin
  LUserData := nil;
  if AName = 'usrid' then
    LUserData := FUserData;

  if LUserData = nil then
    result := ''
  else if Aparam = '' then
    result := LUserData.user_user_id
  else if Aparam = 'firstname' then
    result := LUserData.firstname
  else if Aparam = 'lastname' then
    result := LUserData.lastname
  else if Aparam = 'tel' then
    result := LUserData.tel
  else if Aparam = 'email' then
    result := LUserData.email
  else if Aparam = 'shortname' then
    result := LUserData.shortname
  else
    result := LUserData.user_user_id;
end;

procedure TdataMain.Init;
begin
  case gvInterType of
    itClient: begin
      gvStart := 1100;
      InitDBClient;
      gvStart := 1200;
      CheckPassword;
      gvStart := 1300;
      TBafTranslationModule.ClassSetLanguage(dataMain.UserIni.ReadString
          (CAT_LANGUAGE, 'Language', 'deutsch'));
      gvStart := 1400;
    end;
    itSrvProc: InitDbSrvProc;
  end;
end;

procedure TdataMain.InitDBClient;
// reads the settings from the primary ini file
begin
  FRoot := ExtractFilePath(ParamStr(0));
  gv_root := FRoot;
  ForceDirectories(IncludeTrailingPathDelimiter(FRoot) + 'key');
  FIni := TStringIniFile.Create(FRoot + 'BafClientFM.ini');
  FProgName := FIni.ReadString(CAT_SYS, 'ProgName', 'BAF Client');
  gvStart := 1105;
  frmMain.DoubleClickSclale := FIni.ReadInteger(CAT_SYS, 'DCScale', 100);
  FDefaultMaxRows := FIni.ReadInteger(CAT_SYS, 'DefaultMaxRows', 1000);
  gvStart := 1110;
  if Assigned(dataWD) then
    dataWD.Init;
  gvStart := 1115
  ;
  FUserRoot := GetSpecialFolder(CSIDL_APPDATA) + '\BAF\BafClient';
  ForceDirectories(FUserRoot);
  FUserRoot := FUserRoot + '\';
  gv_userroot := FUserRoot;
  FUserIni := TStringIniFile.Create(FUserRoot + 'BafClientFM.ini');
  gvStart := 1120;

  FDbName := FIni.ReadString('DB', 'db_' + IntToStr(gvDbIndex), '');
  FDriver := AnsiLowerCase(FIni.ReadString(FDbName, 'DriverName', ''));

  FDefaultCon := TBafDbCon.Create;
  FDefaultCon.FDbName := FDbName;
  FDefaultCon.DriverName := FDriver;
  FDefaultCon.BafGen := GetBafGeneration(FIni.ReadString(FDbName, 'BG', ''));
  FDefaultCon.FCommandTable := FIni.ReadString(FDbName, 'CommandTable', 'sys_commands');
  FDefaultCon.FCommandTableHist := FIni.ReadString(FDbName, 'CommandHistTable', 'sys_commands_hist');
  FDefaultCon.FCommandTableId := FIni.ReadString(FDbName, 'CommandTableId', 'sys_commands_id');
  FDefaultCon.FHistExt := FIni.ReadString(FDbName, 'HistExt', '_hist');
  FDefaultCon.FIdExt := FIni.ReadString(FDbName, 'IdExt', '_id');
  FDefaultCon.FProgChg := FIni.ReadString(FDbName, 'ProgChg', 'BC') + ' - ';
  gvStart := 1125;

  FDefaultCon.InitLog;
  gvStart := 1126;
  gvStartText := FDbName + ' - ' + FDriver;
  ConnectDatabase(FDefaultCon.FConnection, FDbName, FDriver);
  gvStart := 1127;
  FDbConnectionList.AddObject(DC_DEFAULT, FDefaultCon);
  gvStart := 1130;

  ConnectAdditionalDB;
  gvStart := 1135;
end;

procedure TdataMain.InitDbSrvProc;
// reads the settings from the primary ini file
begin
  FRoot := ExtractFilePath(ParamStr(0));
  FIni := TStringIniFile.Create(FRoot + 'BafServerFM.ini');
  FProgName := Ini.ReadString(CAT_FRM, 'ServerName', '');
  FDefaultMaxRows := FIni.ReadInteger(CAT_SYS, 'DefaultMaxRows', 1000);
  if Assigned(dataWD) then
    dataWD.Init;

  FUserRoot := GetSpecialFolder(CSIDL_APPDATA) + '\BAF\BafSrvProc';
  ForceDirectories(FUserRoot);
  FUserRoot := FUserRoot + '\';
  FUserIni := TStringIniFile.Create(FUserRoot + 'BafSrvProcFM.ini');

  FDbName := FIni.ReadString('DB', 'sec', '');
  FDriver := AnsiLowerCase(FIni.ReadString(FDbName, 'DriverName', ''));
  FDefaultCon := TBafDbCon.Create;
  FDefaultCon.DbName := FDbName;
  FDefaultCon.DriverName := FDriver;
  FDefaultCon.BafGen := GetBafGeneration(FIni.ReadString(FDbName, 'BG', ''));
  FDefaultCon.FCommandTable := FIni.ReadString(FDbName, 'CommandTable', 'sys_commands');
  FDefaultCon.FCommandTableHist := FIni.ReadString(FDbName, 'CommandHistTable', 'sys_commands_hist');
  FDefaultCon.FCommandTableId := FIni.ReadString(FDbName, 'CommandTableId', 'sys_commands_id');
  FDefaultCon.FHistExt := FIni.ReadString(FDbName, 'HistExt', '_hist');
  FDefaultCon.FIdExt := FIni.ReadString(FDbName, 'IdExt', '_id');
  FDefaultCon.FProgChg := FIni.ReadString(FDbName, 'ProgChg', 'BC') + ' - ';
  FTableNameSrv := FIni.ReadString(FDbName, 'NameSrv', 'sys_srv');
  FTableNameLogLine := FIni.ReadString(FDbName, 'NameLogLine', 'sys_srv_log_line');
  FTableNameLog := FIni.ReadString(FDbName, 'NameLog', 'sys_srv_log');

  FDefaultCon.InitLog;
  ConnectDatabase(FDefaultCon.FConnection, FDbName, FDriver);
  FDbConnectionList.AddObject(DC_DEFAULT, FDefaultCon);

//  ConnectAdditionalDB;       nicht bei SrvProc
end;

function TdataMain.LoadDataMemo(AItem, ARef: string;
    var AId, AText: string): boolean;
var
  LSql: string;
  LParams: TBafParams;
  LDataset: TDataset;
begin
  case DefaultCon.BafGen of
    bg303TT: LSql := 'select * from neuland.data_memo '
        + 'where item = :kitem and ref = :kref';
  else
    LSql := 'select * from data_memo where item = :kitem and ref = :kref';
  end;
  LParams := QueryPrepare(DefaultCon, QEN_DATAMEMO, LSql);
  LParams.ParamAsString('kitem', AItem);
  LParams.ParamAsString('kref', ARef);
  LDataset := QueryOpen(DefaultCon, QEN_DATAMEMO);
  result := not LDataset.Eof;
  if result then begin
    AId := LDataset.FieldByName('data_memo_id').AsString;
    case DefaultCon.BafGen of
      bg303, bg303TT: AText := LDataset.FieldByName('ctext').AsString;
    else
      AText := LDataset.FieldByName('text').AsString;
    end;
  end;
end;

procedure TdataMain.QueryClose(ABafConName, AName: string);
var
  LQuery: TDataSet;
  LAddDb: TBafDbCon;
begin
  LAddDb := GetBafDbCon(ABafConName);
  LQuery := LAddDb.GetQuery(AName).Query;
  LQuery.Close;
  LAddDb.RemoveQuery(AName);
end;

procedure TdataMain.QueryClose(AAddDb: TBafDbCon; AName: string);
var
  LQuery: TDataSet;
begin
  LQuery := AAddDb.GetQuery(AName).Query;
  LQuery.Close;
  AAddDb.RemoveQuery(AName);
end;

function TdataMain.QueryData(AName: string): TDataset;
var
  LIndex: integer;
begin
  result := nil;
  LIndex := mvQueryList.IndexOf(AName);
  if LIndex > -1 then
    result := (mvQueryList.Objects[LIndex] as TBafParams).Query;
end;

function TdataMain.QueryData(AAddDb: TBafDbCon; AName: string): TDataset;
begin
  result := nil;
  if Assigned(AAddDb) then
    result := AAddDb.GetQuery(AName).Query;
end;

function TdataMain.QueryData(ABafConName, AName: string): TDataSet;
var
  LAddDb: TBafDbCon;
begin
  result := nil;
  LAddDb := GetBafDbCon(ABafConName);
  if Assigned(LAddDb) then
    result := LAddDb.GetQuery(AName).Query;
end;

function TdataMain.QueryExecute(AAddDb: TBafDbCon; AName: string): integer;
var
  LParams: TBafParams;
begin
  result := -1;
  if Assigned(AAddDb) then begin
    LParams := AAddDb.GetQuery(AName);
    if CheckDebugExec(LParams.Query.Sql.Text, LParams) then begin
//      LParams.Query.SpecificOptions.Clear;
//      LParams.Query.SpecificOptions.Add('CommandTimeout=30');
      LParams.Query.ExecSQL;
      result := LParams.Query.RowsAffected;
    end;
  end;
end;

function TdataMain.QueryExecute(ABafConName, AName: string): integer;
var
  LAddDb: TBafDbCon;
  LParams: TBafParams;
begin
  result := -1;
  LAddDb := GetBafDbCon(ABafConName);
  if Assigned(LAddDb) then begin
    LParams := LAddDb.GetQuery(AName);
    if CheckDebugExec(LParams.Query.Sql.Text, LParams) then begin
      LParams.Query.ExecSQL;
      result := LParams.Query.RowsAffected;
    end;
  end;
end;

function TdataMain.QueryOpen(AAddDb: TBafDbCon; AName: string;
    ACmd: boolean = false): TDataset;
var
  LParams: TBafParams;
  c, t, t1, t2: int64;
begin
  result := nil;
  if Assigned(AAddDb) then begin
    LParams := AAddDb.GetQuery(AName);
    if CheckDebugSelect(LParams, ACmd) then begin
      QueryPerformanceFrequency(c);
      QueryPerformanceCounter(t1);
      LParams.Query.Open;
      QueryPerformanceCounter(t2);
      t := 1000 * (t2 - t1) div c;
      BafPerformanceLog(Format('QueryOpen: %d', [t]));
    end;
    result := LParams.Query;
  end;
end;

function TdataMain.QueryOpen(ABafConName, AName: string;
    ACmd: boolean = false): TDataSet;
var
  LAddDb: TBafDbCon;
  LParams: TBafParams;
  c, t, t1, t2: int64;
begin
  result := nil;
  LAddDb := GetBafDbCon(ABafConName);
  if Assigned(LAddDb) then begin
    LParams := LAddDb.GetQuery(AName);
    if CheckDebugSelect(LParams, ACmd) then begin
      QueryPerformanceFrequency(c);
      QueryPerformanceCounter(t1);
      LParams.Query.Open;
      QueryPerformanceCounter(t2);
      t := 1000 * (t2 - t1) div c;
      BafPerformanceLog(Format('QueryOpen: %d', [t]));
    end;
    result := LParams.Query;
  end;
end;

function TdataMain.QueryPrepare(AAddDb: TBafDbCon; AName, ASql: string;
  AType: TBafQueryType): TBafParams;
begin
  if Assigned(AAddDb) then begin
    result := AAddDb.GetQuery(AName, AType);
    result.Query.Sql.Text := ASql;
    result.Query.Prepare;
  end
  else
    result := nil;
end;

function TdataMain.QueryPrepare(ABafConName, AName, ASql: string;
    AType: TBafQueryType = qtMain): TBafParams;
var
  LAddDb: TBafDbCon;
begin
  LAddDb := GetBafDbCon(ABafConName);
  if Assigned(LAddDb) then begin
    result := LAddDb.GetQuery(AName, AType);
    result.Query.Sql.Text := ASql;
  end
  else
    result := nil;
end;

procedure TdataMain.RefreshLookup(AName: string; AHelper: TBafComboHelper);
var
  LSql: string;
  LBafGen: TBafGeneration;
begin
  LBafGen := DefaultCon.BafGen;
  LSql := TDataHistSql.RefreshLookup(dataMain.Driver, AName, LBafGen);
  LSql := ReplaceSqlFunction(LSql);
  case LBafGen of
    bg302, bg303, bg303TT: AHelper.FillFromQuery(LSql, 'ckey', 'cvalue', AName);
    else
      AHelper.FillFromQuery(LSql, 'key', 'value', AName);
  end;
end;

procedure TdataMain.RefreshSpecial(AName: string; AHelper: TBafComboHelper);
var
  LSql: string;
  LParams: TBafParams;
  LDataSet: TDataSet;
begin
  case DefaultCon.BafGen of
    bg303TT:
      LSql := 'select code from neuland.data_special where name = :name';
    else
      LSql := 'select code from data_special where name = :name';
  end;
  LParams := QueryPrepare(DefaultCon, 'system_special', LSql);
  LParams.ParamAsString('name', AName);
  LDataSet := QueryOpen(DefaultCon, 'system_special');
  LSql := '';
  if not LDataSet.Eof then
    LSql := ReplaceSqlFunction(LDataSet.Fields[0].AsString);
  if LSQL <> '' then begin
    case DefaultCon.BafGen of
      bg302, bg303, bg303TT: AHelper.FillFromQuery(LSql, 'ckey', 'cvalue', '');
      else
        AHelper.FillFromQuery(LSql, 'key', 'value', '');
    end;
  end;
end;

function TdataMain.ReplaceSqlFunction(AText: string): string;
begin
  result := mvInterpreter.ReplaceFunctions(AText);
end;

procedure TdataMain.Rollback(ABafConName: string);
var
  LAddDb: TBafDbCon;
begin
  LAddDb := GetBafDbCon(ABafConName);
  if CanTransactions(ABafConName) then
    LAddDb.FTransaction.Rollback;
end;

procedure TdataMain.SaveDataMemo(AItem, ARef, AId, AText, AFunctionName: string);
var
  LSql: string;
  LParams: TBafParams;
begin
  if AId = '' then begin
    case DefaultCon.BafGen of
      bg303: LSql := 'insert into data_memo (data_memo_id, item, ref, ctext, datechg, '
        + 'usrchg, progchg) values '
        + '(:data_memo_id, :item, :ref, :ctext, :datechg, :usrchg, :progchg)';
      bg303TT: LSql := 'insert into neuland.data_memo (data_memo_id, item, ref, '
        + 'ctext, datechg, usrchg, progchg) values '
        + '(:data_memo_id, :item, :ref, :ctext, :datechg, :usrchg, :progchg)';
    else
      LSql := 'insert into data_memo (data_memo_id, item, ref, text, datechg, '
          + 'usrchg, progchg) values '
          + '(:data_memo_id, :item, :ref, :ctext, :datechg, :usrchg, :progchg)';
    end;
  end
  else begin
    case DefaultCon.BafGen of
      bg303: LSql := 'update data_memo set ctext = :ctext, datechg = :datechg, '
        + 'usrchg = :usrchg, progchg = :progchg where data_memo_id = :data_memo_id';
      bg303TT: LSql := 'update neuland.data_memo set ctext = :ctext, datechg = :datechg, '
        + 'usrchg = :usrchg, progchg = :progchg where data_memo_id = :data_memo_id';
    else
      LSql := 'update data_memo set text = :ctext, datechg = :datechg, '
        + 'usrchg = :usrchg, progchg = :progchg where data_memo_id = :data_memo_id';
    end;
  end;
  LParams := QueryPrepare(DefaultCon, QEN_DATAMEMO, LSql);
  LParams.ParamAsString('ctext', AText);
  LParams.ParamAsDateTime('datechg', now);
  if DefaultCon.BafGen = bg303TT then
    LParams.ParamAsString('usrchg', dataMain.UserId)
  else
    LParams.ParamAsString('usrchg', dataMain.UserGuid);
  LParams.ParamAsString('progchg', copy('BC - ' + AFunctionName, 1, 20));
  if AId = '' then begin
    LParams.ParamAsString('data_memo_id', BafGetGuid);
    LParams.ParamAsString('item', AItem);
    LParams.ParamAsString('ref', ARef);
  end
  else
    LParams.ParamAsString('data_memo_id', AId);
  QueryExecute(DefaultCon, QEN_DATAMEMO);
end;

function TdataMain.SetMigrationDB(AIndex: integer; var ADriverName: string): string;
var
  LDbName: string;
  ix: integer;
begin
  ix := FDbConnectionList.IndexOf(DC_MIG);
  if ix >= 0 then
    FDbConnectionList.Delete(ix);
  LDbName := FIni.ReadString('DB', 'db_' + IntToStr(AIndex), '');
  ADriverName := AnsiLowerCase(FIni.ReadString(LDbName, 'DriverName', ''));
  FMigCon := TBafDbCon.Create;
  try
    FMigCon.DriverName := ADriverName;
    FMigCon.BafGen := GetBafGeneration(FIni.ReadString(LDbName, 'BG', ''));
    FMigCon.FCommandTable := FIni.ReadString(LDbName, 'CommandTable', 'sys_commands');
    FMigCon.FCommandTableHist := FIni.ReadString(LDbName, 'CommandHistTable', 'sys_commands_hist');
    FMigCon.FCommandTableId := FIni.ReadString(LDbName, 'CommandTableId', 'sys_commands_id');
    FMigCon.FHistExt := FIni.ReadString(LDbName, 'HistExt', '_hist');
    FMigCon.FIdExt := FIni.ReadString(LDbName, 'IdExt', '_id');
    FMigCon.BafGen := GetBafGeneration(FIni.ReadString(LDbName, 'BG', ''));

    ConnectDatabase(FMigCon.FConnection, LDbName, ADriverName);
    result := LDbName;
  except
    on E: Exception do
      ShowMessage('Error connecting Migration-DB ' + #13#10 + E.Message);
  end;
  FDbConnectionList.AddObject(DC_MIG, FMigCon);
end;

procedure TdataMain.StartTransaction(ABafConName: string);
var
  LAddDb: TBafDbCon;
begin
  LAddDb := GetBafDbCon(ABafConName);
  if CanTransactions(ABafConName) then
    LAddDb.FTransaction.StartTransaction;
end;

procedure TdataMain.Sync2Desc(ATableName, AKeyName, AWhere: string);
begin

end;

procedure TdataMain.ThreadQueryClose(ABafConName: string; AConPoolIx: integer);
var
  LAddDb: TBafDbCon;
  LThreadCon: TBafThreadCon;
begin
  LAddDb := GetBafDbCon(ABafConName);
  LThreadCon := LAddDb.GetThreadCon(AConPoolIx);
  LThreadCon.FParams.Query.Close;
  LAddDb.FLock.Acquire;
  try
    LThreadCon.Active := false;
  finally
    LAddDb.FLock.Release;
  end;
end;

function TdataMain.ThreadQueryOpen(ABafConName: string; AConPoolIx: integer): TDataset;
var
  LAddDb: TBafDbCon;
  LThreadCon: TBafThreadCon;
begin
  LAddDb := GetBafDbCon(ABafConName);
  LThreadCon := LAddDb.GetThreadCon(AConPoolIx);
  LThreadCon.FParams.Query.Close;
  LThreadCon.FParams.Query.Open;
  result := LThreadCon.FParams.Query;
end;

function TdataMain.ThreadQueryPrepare(ABafConName, ASql: string;
    var AConPoolIx: integer): TBafParams;
var
  LAddDb: TBafDbCon;
  LThreadCon: TBafThreadCon;
begin
  LAddDb := GetBafDbCon(ABafConName);
  if Assigned(LAddDb) then begin
    LThreadCon := LAddDb.AcquireThreadCon;
    AConPoolIx := LThreadCon.Ix;
    result := LThreadCon.FParams;
    result.Query.Sql.Text := ASql;
  end
  else
    result := nil;
end;

procedure TdataMain.UpsertIni(AIni: TStringIniFile; ABafConName, AProg: string;
  var ARowAffected: integer; AMultiLineFields: TStringList);
// we get data in ini format to store
// historisation is done by trigger and can be ignored here
var
  LBafGen: TBafGeneration;
  LTableName, LKeyField, LKeyValue, LSql, s, s2, LName: string;
  sl, LLines: TStringList;
  LCheckMulti, LExec: boolean;
  LAddDb: TBafDbCon;

  procedure lokInsert;
  var
    i: integer;
  begin
    s := '';
    s2 := '';
    for i := 0 to sl.Count - 1 do begin
      s := s + ', ' + sl[i];
      s2 := s2 + ', :' + sl[i];
    end;
    LSql := Format('insert into %s (%s) ' + #13#10 + 'values (%s)',
        [LTableName, copy(s, 3, MaxInt), copy(s2, 3, MaxInt)]);
  end; // procedure lokInsert


  procedure lokParam;
  var
    LParams: TBafParams;
    i, ix: integer;
    LParamName: string;
    LTyp: Char;
  begin
    ix := 0;
    LParams := QueryPrepare(ABafConName, LName, LSql);
    for i := 0 to LParams.Count - 1 do begin
      LParamName := AnsiLowerCase(LParams.GetParamName(i));
      if LCheckMulti then
        ix := AMultiLineFields.IndexOf(LParamName);
      // AMultiLineFields is a TStringList with parameter in lower case,
      // in the Objects there are further TStringList objects
      if LCheckMulti and (ix >= 0) then begin
        LLines := AMultiLineFields.Objects[ix] as TStringList;
        LParams.ParamAsString(i, LLines.Text);
      end
      else begin
        s := AIni.ReadString(SEC_DATA, LParamName, '');
        LTyp := GetFieldDef(ABafConName, LTableName, LParamName);
        if LTyp <> '' then begin
          case LTyp of
            'C': if s = '' then
                LParams.ParamNull(i)
              else
                LParams.ParamAsCurrency(i, StrToCurr(s));
            'D': if s = '' then
                LParams.ParamNull(i)
              else
                LParams.ParamAsDateTime(i, StrToDateTime(s));
            'F': if s = '' then
                LParams.ParamNull(i)
              else
                LParams.ParamAsFloat(i, StrToFloat(s));
            'I': if s = '' then
                LParams.ParamNull(i)
              else
                LParams.ParamAsInteger(i, StrToInt(s));
          else
            LParams.ParamAsString(i, s);
          end;
        end
        else
          LParams.ParamAsString(i, s);
      end;
    end;
  end; // procedure lokParam

  procedure lokUpdate;
  var
    i: integer;
    LDataSet: TDataSet;
  begin
    if AIni.ReadBool(SEC_ADD, 'checkupdate', false) then begin
      s := '';
      for i := 0 to sl.Count - 1 do begin
        if (AnsiCompareText(sl[i], 'usrchg') <> 0)
            and (AnsiCompareText(sl[i], 'datechg') <> 0)
            and (AnsiCompareText(sl[i], 'progchg') <> 0) then
        s := s + ' and ' + sl[i] + ' = :' + sl[i];
      end;
      LSql := Format('select count(*) as cnt from %s where %s',
          [LTableName, copy(s, 6, MaxInt)]);
      lokParam;
      LDataSet := QueryOpen(LAddDb, LName);
      LExec := (LDataSet.FieldByName('cnt').AsInteger = 0);
    end;
    s := '';
    for i := 0 to sl.Count - 1 do
      s := s + ', ' + sl[i] + ' = :' + sl[i];
    LSql := Format('update %s set %s where %s = %s',
        [LTableName, copy(s, 3, MaxInt), LKeyField, QuotedStr(LKeyValue)]);
  end; // procedure lokUpdate

  procedure lokAutoIns;
  // check, if there is a data row with this key
  var
    LDataSet: TDataSet;
  begin
    LSql := Format('select count(*) as cnt from %s where %s = %s',
        [LTableName, LKeyField, QuotedStr(LKeyValue)]);
    QueryPrepare(LAddDb, LName, LSql);
    LDataSet := QueryOpen(LAddDb, LName);
    if LDataSet.FieldByName('cnt').AsInteger = 0 then
      AIni.WriteBool(SEC_ADD, 'ins', true);
  end; // procedure lokAutoIns

begin
  if CheckDebugUpsert(AIni) then begin
    LAddDb := GetBafDbCon(ABafConName);
    LName := QEN_UPSERT + '~' + ABafConName;
    LCheckMulti := Assigned(AMultiLineFields);
    try
      LTableName := AIni.ReadString(SEC_ADD, 't', '');
      LKeyField := AIni.ReadString(SEC_ADD, 'k', '');
      LKeyValue := AIni.ReadString(SEC_ADD, 'kv', '');
      if (LTableName <> '') and (LKeyField <> '') and (LKeyValue <> '') then begin
        sl := TStringList.Create;
        try
          if AIni.ReadBool(SEC_ADD, 'hst', false) then begin
            LBafGen := LAddDb.BafGen;
            if LBafGen in [bg303TT] then
              AIni.WriteString(SEC_DATA, 'usrchg', dataMain.UserId)
            else
              AIni.WriteString(SEC_DATA, 'usrchg', dataMain.UserGuid);
            AIni.WriteDateTime(SEC_DATA, 'datechg', now);
            if LAddDb.BafGen in [bg303TT] then
              AIni.WriteString(SEC_DATA, 'progchg', copy(AProg, 1, 20))
            else
              AIni.WriteString(SEC_DATA, 'progchg', copy(AProg, 1, 40));
          end;
          AIni.ReadSection(SEC_DATA, sl);
          LExec := true;
          if AIni.ReadBool(SEC_ADD, 'autoins', false) then
            lokAutoIns;
          if AIni.ReadBool(SEC_ADD, 'ins', false) then
            lokInsert
          else
            lokUpdate;
          if LExec then begin
            lokParam;
            ARowAffected := QueryExecute(LAddDb, LName);
          end;
        finally
          sl.Free;
        end;
      end
      else begin
        if Assigned(frmMain) then
          frmMain.Log('E', Format('Upsert   Database: %s   LTableName: %s   '
              + 'LKeyField: %s   LKeyValue: %s',
              [ABafConName, LTableName, LKeyField, LKeyValue]));
      end;
    finally
      if Assigned(AMultiLineFields) then begin
        AMultiLineFields.OwnsObjects := true;
        AMultiLineFields.Free;
      end;
    end;
  end;
// procedure TdataMain.UpsertIni
end;

procedure TdataMain.UpsertIni2(AIni: TStringIniFile; ABafConName, AProg, ASql: string;
  var ARowAffected: integer; var AKeyValue: string; AUpsert2KeyValue: TUpsert2KeyValue;
  AMultiLineFields: TStringList);
// we get data in ini format to store
// insert or update or nothing is done automatically
var
  LBafGen: TBafGeneration;
  LTableName, LKeyField, LSql, s, s2, LName: string;
  sl, LLines: TStringList;
  LCheckMulti, LExec: boolean;
  LAddDb: TBafDbCon;

  procedure lokInsert;
  var
    i: integer;
  begin
    s := '';
    s2 := '';
    for i := 0 to sl.Count - 1 do begin
      s := s + ', ' + sl[i];
      s2 := s2 + ', :' + sl[i];
    end;
    LSql := Format('insert into %s (%s) ' + #13#10 + 'values (%s)',
        [LTableName, copy(s, 3, MaxInt), copy(s2, 3, MaxInt)]);
  end; // procedure lokInsert


  procedure lokParam;
  var
    LParams: TBafParams;
    i, ix: integer;
    LParamName: string;
    LTyp: Char;
  begin
    ix := 0;
    LParams := QueryPrepare(ABafConName, LName, LSql);
    for i := 0 to LParams.Count - 1 do begin
      LParamName := AnsiLowerCase(LParams.GetParamName(i));
      if LCheckMulti then
        ix := AMultiLineFields.IndexOf(LParamName);
      // AMultiLineFields is a TStringList with parameter in lower case,
      // in the Objects there are further TStringList objects
      if LCheckMulti and (ix >= 0) then begin
        LLines := AMultiLineFields.Objects[ix] as TStringList;
        LParams.ParamAsString(i, LLines.Text);
      end
      else begin
        s := AIni.ReadString(SEC_DATA, LParamName, '');
        LTyp := GetFieldDef(ABafConName, LTableName, LParamName);
        if LTyp <> '' then begin
          case LTyp of
            'C': if s = '' then
                LParams.ParamNull(i)
              else
                LParams.ParamAsCurrency(i, StrToCurr(s));
            'D': if s = '' then
                LParams.ParamNull(i)
              else
                LParams.ParamAsDateTime(i, StrToDateTime(s));
            'F': if s = '' then
                LParams.ParamNull(i)
              else
                LParams.ParamAsFloat(i, StrToFloat(s));
            'I': if s = '' then
                LParams.ParamNull(i)
              else
                LParams.ParamAsInteger(i, StrToInt(s));
          else
            if (s = '') and (LAddDb.DriverName = 'oracle') then
              LParams.ParamNull(i)
            else
              LParams.ParamAsString(i, s);
          end;
        end
        else
          LParams.ParamAsString(i, s);
      end;
    end;
  end; // procedure lokParam

  procedure lokUpdate;
  var
    i: integer;
    LDataSet: TDataSet;
    LTyp: Char;
    LValue: string;
  begin
    // do we have to update or are all fields up to date?
    s := '';
    for i := 0 to sl.Count - 1 do begin
      if (AnsiCompareText(sl[i], 'usrchg') <> 0)
          and (AnsiCompareText(sl[i], 'datechg') <> 0)
          and (AnsiCompareText(sl[i], 'progchg') <> 0) then begin
        LTyp := GetFieldDef(ABafConName, LTableName, sl[i]);
        LValue := AIni.ReadString(SEC_DATA, sl[i], '');
        if LTyp <> '' then begin
          case LTyp of
            'C', 'D', 'F', 'I': if (LValue = '') then
              s := s + ' and ' + sl[i] + ' is null'
            else
              s := s + ' and ' + sl[i] + ' = :' + sl[i];
          else
            if (LValue = '') and (LAddDb.DriverName = 'oracle') then
              s := s + ' and ' + sl[i] + ' is null'
            else
              s := s + ' and ' + sl[i] + ' = :' + sl[i];
          end;
        end
        else
          s := s + ' and ' + sl[i] + ' = :' + sl[i];
      end;
    end;
    LSql := Format('select count(*) as cnt from %s where %s',
        [LTableName, copy(s, 6, MaxInt)]);
    lokParam;
    LDataSet := QueryOpen(LAddDb, LName);
    LExec := (LDataSet.FieldByName('cnt').AsInteger = 0);

    // create the sql statement
    if LExec then begin
      s := '';
      for i := 0 to sl.Count - 1 do
        s := s + ', ' + sl[i] + ' = :' + sl[i];
      LSql := Format('update %s set %s where %s = %s',
          [LTableName, copy(s, 3, MaxInt), LKeyField, QuotedStr(AKeyValue)]);
    end;
  end; // procedure lokUpdate

  procedure lokUpdateOra;
  var
    i: integer;
    LDataSet: TDataSet;
    LValue: string;
  begin
    // do we have to update or are all fields up to date?
    s := '';
    for i := 0 to sl.Count - 1 do begin
      if (AnsiCompareText(sl[i], 'usrchg') <> 0)
          and (AnsiCompareText(sl[i], 'datechg') <> 0)
          and (AnsiCompareText(sl[i], 'progchg') <> 0) then begin
        LValue := AIni.ReadString(SEC_DATA, sl[i], '');
        if LValue = '' then
          s := s + ' and ' + sl[i] + ' is null'
        else
          s := s + ' and ' + sl[i] + ' = :' + sl[i];
      end;
    end;
    LSql := Format('select count(*) as cnt from %s where %s',
        [LTableName, copy(s, 6, MaxInt)]);
    lokParam;
    LDataSet := QueryOpen(LAddDb, LName);
    LExec := (LDataSet.FieldByName('cnt').AsInteger = 0);

    // create the sql statement
    if LExec then begin
      s := '';
      for i := 0 to sl.Count - 1 do
        s := s + ', ' + sl[i] + ' = :' + sl[i];
      LSql := Format('update %s set %s where %s = %s',
          [LTableName, copy(s, 3, MaxInt), LKeyField, QuotedStr(AKeyValue)]);
    end;
  end; // procedure lokUpdateOra


  procedure lokCheckData;
  // check wether we have to insert or update
  var
    LDataSet: TDataSet;
    i: integer;
    s, LFieldName, LFieldValue, LFieldType: string;
  begin
    LExec := true;
    QueryPrepare(LAddDb, LName, ASql);
    LDataSet := QueryOpen(LAddDb, LName);
    if LDataSet.Eof then begin
      case AUpsert2KeyValue of
        ukvNull: AKeyValue := '';
        ukv0: AKeyValue := '0';
        ukvValue: AKeyValue := AIni.ReadString(SEC_DATA, LKeyField, '');
      else
        AKeyValue := BafGetGuid;
      end;
      AIni.WriteString(SEC_DATA, LKeyField, AKeyValue);
      lokInsert;
    end
    else begin
      AKeyValue := LDataSet.Fields[0].AsString;
      AIni.WriteString(SEC_DATA, LKeyField, AKeyValue);
      if LAddDb.DriverName = 'oracle' then
        lokUpdateOra
      else
        lokUpdate;
    end;

    if LExec then begin
      lokParam;
      ARowAffected := QueryExecute(LAddDb, LName);
    end;
  end; // procedure lokCheckData

begin
  if CheckDebugUpsert(AIni) then begin
    LAddDb := GetBafDbCon(ABafConName);
    LName := QEN_UPSERT + '~' + ABafConName;
    LCheckMulti := Assigned(AMultiLineFields);
    try
      LTableName := AIni.ReadString(SEC_ADD, 't', '');
      LKeyField := AIni.ReadString(SEC_ADD, 'k', '');
      if (LTableName <> '') and (LKeyField <> '') then begin
        sl := TStringList.Create;
        try
          if AIni.ReadBool(SEC_ADD, 'hst', false) then begin
            LBafGen := LAddDb.BafGen;
            if LBafGen in [bg303TT] then
              AIni.WriteString(SEC_DATA, 'usrchg', dataMain.UserId)
            else
              AIni.WriteString(SEC_DATA, 'usrchg', dataMain.UserGuid);
            AIni.WriteDateTime(SEC_DATA, 'datechg', now);
            if LAddDb.BafGen in [bg303TT] then
              AIni.WriteString(SEC_DATA, 'progchg', copy(AProg, 1, 20))
            else
              AIni.WriteString(SEC_DATA, 'progchg', copy(AProg, 1, 40));
          end;
          AIni.ReadSection(SEC_DATA, sl);
          lokCheckData;
        finally
          sl.Free;
        end;
      end
      else begin
        if Assigned(frmMain) then
          frmMain.Log('E', Format('Upsert2   Database: %s   LTableName: %s   '
              + 'LKeyField: %s  ', [ABafConName, LTableName, LKeyField]));
      end;
    finally
      if Assigned(AMultiLineFields) then begin
        AMultiLineFields.OwnsObjects := true;
        AMultiLineFields.Free;
      end;
    end;
  end;
// procedure TdataMain.UpsertIni2
end;

function TdataMain.WriteCommand(ABafConName, AId, AName, ACode, AParent: string;
    AMode: char; var ADateChg: TDateTime): boolean;
var
  LSql, LDebug: string;
  LParams: TBAFParams;
  LDataSet: TDataSet;
  LBafDbCon: TBafDbCon;

  procedure lokParams;
  var
    LRows: integer;
  begin
    LParams := QueryPrepare(LBafDbCon, QEN_COMMAND, LSql);
    if AMode = 'U' then
      LParams.ParamAsDateTime('olddate', ADateChg);
    LParams.ParamAsString('id', AId);
    LParams.ParamAsString('name', AName);
    LParams.ParamAsString('code', ACode, LBafDbCon.DriverName = 'oracle');
    LParams.ParamAsString('parent', AParent);
    if LBafDbCon.BafGen = bg303TT then
      LParams.ParamAsString('usrchg', UserId)
    else
      LParams.ParamAsString('usrchg', UserGuid);
    ADateChg := now;
    LParams.ParamAsDateTime('datechg', ADateChg);
    LParams.ParamAsString('progchg', Progname);

    LDebug := LSql + #13#10 + ACode + #13#10 + AId + #13#10 + AParent + #13#10;
    LRows := QueryExecute(LBafDbCon, QEN_COMMAND);
    result := (LRows = 1);
  end; // procedure lokParams

begin
  LBafDbCon := GetBafDbCon(ABafConName);
  case AMode of
    'I': begin
      case LBafDbCon.BafGen of
        bg302, bg303, bg303TT: LSql := Format('insert into %s (%s, name, code, '
            + 'parent, usrchg, datechg, progchg) '
            + 'values (:id, :name, :code, :parent, :usrchg, :datechg, :progchg)',
            [LBafDbCon.CommandTable, LBafDbCon.CommandTableId]);
      else
        LSql := Format('insert into %s (%s, name, code, '
            + 'parent, userchg, datechg, progchg) '
            + 'values (:id, :name, :code, :parent, :usrchg, :datechg, :progchg)',
            [LBafDbCon.CommandTable, LBafDbCon.CommandTableId]);
      end;
      lokParams;
    end;
    'U': begin
      case LBafDbCon.BafGen of
        bg302, bg303, bg303TT: LSql := Format('update %s set name = :name, '
          + 'code = :code, parent = :parent, datechg = :datechg, usrchg = :usrchg, '
          + 'progchg = :progchg where %s = :id and datechg = :olddate',
            [LBafDbCon.CommandTable, LBafDbCon.CommandTableId]);
      else
      LSql := Format('update %s set name = :name, code = :code, '
          + 'parent = :parent, datechg = :datechg, userchg = :usrchg, '
          + 'progchg = :progchg where %s = :id and datechg = :olddate',
            [LBafDbCon.CommandTable, LBafDbCon.CommandTableId]);
      end;
      lokParams;
    end;
    'A': begin
      LSql := Format('select count(*) from %s where %s = :id',
            [LBafDbCon.CommandTable, LBafDbCon.CommandTableId]);
      LParams := QueryPrepare(LBafDbCon, QEN_COMMAND, LSql);
      LParams.ParamAsString('id', AId);
      LDataSet := QueryOpen(LBafDbCon, QEN_COMMAND);
      if LDataSet.Fields[0].AsInteger = 0 then
        result := WriteCommand(ABafConName, AId, AName, ACode, AParent, 'I', ADateChg)
      else
        result := WriteCommand(ABafConName, AId, AName, ACode, AParent, 'U', ADateChg);
    end;
  end;
end;

{ TBafParams }

function TBafParams.Count: integer;
begin
  result := FQuery.Params.Count;
end;

destructor TBafParams.Destroy;
begin
  FQuery.Free;
  inherited;
end;


function TBafParams.GetParamName(AIndex: integer): string;
begin
  result := FQuery.Params[AIndex].Name;
end;

function TBafParams.GetParamNameAndValue(AIndex: integer): string;
begin
  result := FQuery.Params[AIndex].Name + ' = ' + FQuery.Params[AIndex].AsString;
end;

procedure TBafParams.ParamAsString(AIndex: integer; AValue: string;
    AOraClob: boolean = false);
begin
  FQuery.Params[AIndex].AsString := AValue;
end;

procedure TBafParams.ParamNull(AIndex: integer);
begin
  FQuery.Params[AIndex].Clear;
end;

procedure TBafParams.ParamNull(const AParamName: string);
begin
  FQuery.ParamByName(AParamName).Clear;
end;

procedure TBafParams.ParamAsString(const AParamName, AValue: string;
    AOraClob: boolean = false);
var
  LParam: TUniParam;
begin
  if AOraClob then begin
    LParam := FQuery.ParamByName(AParamName);
    LParam.ParamType := ptInput;
    LParam.DataType := ftOraClob;
    LParam.AsBlobRef.AsString := AValue;
  end
  else
    FQuery.ParamByName(AParamName).AsString := AValue;
end;

procedure TBafParams.SetValue(AIndex: integer; AValue: string);
begin
  FQuery.Params[AIndex];
  FQuery.Params[AIndex].AsString := AValue;
end;

procedure TBafParams.ParamAsDateTime(const AParamName: string;
    AValue: TDateTime);
begin
  FQuery.ParamByName(AParamName).AsDateTime := AValue;
end;

procedure TBafParams.ParamAsCurrency(AIndex: integer; AValue: currency);
begin
  FQuery.Params[AIndex].AsCurrency := AValue;
end;

procedure TBafParams.ParamAsCurrency(const AParamName: string;
  AValue: currency);
begin
  FQuery.ParamByName(AParamName).AsCurrency := AValue;
end;

procedure TBafParams.ParamAsDateTime(AIndex: integer; AValue: TDateTime);
begin
  FQuery.Params[AIndex].AsDateTime := AValue;
end;

procedure TBafParams.ParamAsFloat(AIndex: integer; AValue: double);
begin
  FQuery.Params[AIndex].AsFloat := AValue;
end;

procedure TBafParams.ParamAsInteger(AIndex: integer; AValue: integer);
begin
  FQuery.Params[AIndex].AsInteger := AValue;
end;

procedure TBafParams.ParamAsInteger(const AParamName: string; AValue: integer);
begin
  FQuery.ParamByName(AParamName).AsInteger := AValue;
end;

procedure TBafParams.ParamAsFloat(const AParamName: string; AValue: double);
begin
  FQuery.ParamByName(AParamName).AsFloat := AValue;
end;

{ TAddDatabase }

constructor TBafDbCon.Create;
begin
  FConnection := TUniConnection.Create(dataMain);
  FTransaction := TUniTransaction.Create(dataMain);
  FTransaction.DefaultConnection := FConnection;
  FFieldDefs := TStringList.Create;
  FFieldDefs.OwnsObjects := true;
  FFieldDefs.Sorted := true;
  FFieldDefs.Duplicates := dupError;
  FThreadConList := TObjectList.Create;
  FLock := TCriticalSection.Create;
end;

destructor TBafDbCon.Destroy;
begin
  FreeAndNil(FLock);
  FreeAndNil(FThreadConList);
  FreeAndNil(FFieldDefs);
  FreeAndNil(FConnection);
  inherited;
end;

function TBafDbCon.GetQuery(AName: string; AType: TBafQueryType): TBafParams;
var
  LIndex: integer;
  LQuery: TUniQuery;
  LParams: TBafParams;
begin
  AName := AnsiLowerCase(AName);
  LIndex := mvQueryList.IndexOf(AName);
  if LIndex >= 0 then begin
    LParams := (mvQueryList.Objects[LIndex] as TBafParams);
    if LParams.FBafDbCon <> Self then begin
      FreeAndNil(LParams);
      mvQueryList.Delete(LIndex);
      LIndex := -1;
    end;
  end;
  if LIndex = -1 then begin
    LQuery := TUniQuery.Create(FConnection);
    LQuery.Connection := FConnection;
    case AType of
      qtMain: LQuery.Transaction := FTransaction;
      qtLog: LQuery.Transaction := FLogTransaction;
    end;
    LQuery.Transaction := FTransaction;
    LParams := TBafParams.Create;
    LParams.Query := LQuery;
    LParams.BafDbCon := Self;
    LIndex := mvQueryList.AddObject(AName, LParams);
  end;
  result := (mvQueryList.Objects[LIndex] as TBafParams);
end;

function TBafDbCon.GetThreadCon(AIx: integer): TBafThreadCon;
begin
  result := nil;
  if (AIx >= 0) and (AIx < FThreadConList.Count) then
    result := FThreadConList[AIx] as TBafThreadCon;
end;

function TBafDbCon.AcquireThreadCon: TBafThreadCon;
var
  i: integer;
  LFound: boolean;
  LThreadCon: TBafThreadCon;
begin
  result := nil;
  FLock.Acquire;
  try
    LFound := false;
    for i := 0 to FThreadConList.Count - 1 do begin
      LThreadCon := FThreadConList[i] as TBafThreadCon;
      if LThreadCon.Active = false then begin
        LFound := true;
        LThreadCon.Active := true;
        result := LThreadCon;
        Break;
      end;
    end;
    if not LFound then begin
      LThreadCon := TBafThreadCon.Create;
      LThreadCon.Active := true;
      LThreadCon.FIx := FThreadConList.Add(LThreadCon);
      LThreadCon.DriverName := DriverName;
      try
        LThreadCon.ConnectDatabase(DbName, DriverName);
        result := LThreadCon;
      except
        on E: Exception do
          ShowMessage('Error connecting ' + DbName + #13#10 + E.Message);
      end;
    end;
  finally
    FLock.Release;
  end;
end;

procedure TBafDbCon.InitLog;
begin
  FLogTransaction := TUniTransaction.Create(dataMain);
  FLogTransaction.DefaultConnection := FConnection;
end;

procedure TBafDbCon.RemoveQuery(AName: string);
var
  LIndex: integer;
begin
  AName := AnsiLowerCase(AName);
  LIndex := mvQueryList.IndexOf(AName);
  if LIndex > -1 then
    mvQueryList.Delete(LIndex);
end;

{ TBafThreadCon }

procedure TBafThreadCon.ConnectDatabase(ADbName, ADriverName: string);
var
  LFileName, LDir, s, s2: string;
  i: integer;
begin
  FConnection.Connected := false;
  FConnection.ProviderName := dataMain.Ini.ReadString(ADbName, 'uProviderName', '');
  s := dataMain.Ini.ReadString(ADbName, 'uServer', '');
  s2 := dataMain.Ini.ReadString(ADbName, 'uServer2', '');
  if (s2 <> '') and (random(2) mod 2 = 1) then
    s := s2;
  FConnection.Server := s;
  LFileName := dataMain.Ini.ReadString(ADbName, 'Database', '');
  LDir := ExtractFilePath(LFileName);
  if (LDir = '')
      and (AnsiCompareStr(FConnection.Server, 'localhost') = 0)
      and (AnsiCompareText(FConnection.ProviderName, 'PostgreSQL') <> 0)
      and (AnsiCompareText(FConnection.ProviderName, 'MySQL') <> 0) then
    LFileName := IncludeTrailingPathDelimiter(dataMain.Root) + LFileName;
  FConnection.Database := LFileName;
  FConnection.UserName := dataMain.Ini.ReadString(ADbName, 'User', '');
  FConnection.Password := BafDecrypt(dataMain.Ini.ReadString(ADbName, 'Password', ''));

  for i := 1 to 12 do begin
    s := dataMain.Ini.ReadString(ADbName, 'so' + IntToStr(i), '');
    if s <> '' then
      FConnection.SpecificOptions.Add(s);
  end;
  dataMain.ConnectDatabaseDataTypes(FConnection, ADriverName);
  FConnection.Connected := true;
end;

constructor TBafThreadCon.Create;
begin
  FConnection := TUniConnection.Create(dataMain);
  FTransaction := TUniTransaction.Create(dataMain);
  FTransaction.DefaultConnection := FConnection;
  FParams := TBafParams.Create;
  FParams.Query :=  TUniQuery.Create(FConnection);
  FParams.Query.Connection := FConnection;
  FParams.Query.Transaction := FTransaction;
end;

destructor TBafThreadCon.Destroy;
begin

  inherited;
end;

initialization
  mvQueryList := TStringList.Create;
  mvQueryList.OwnsObjects := false;
  mvQueryList.Sorted := true;
  mvQueryList.Duplicates := dupError;


finalization
  FreeAndNil(mvQueryList);

  if Assigned(dataMain) and Assigned(dataMain.UserIni) then begin
    dataMain.UserIni.UpdateFile;
    FreeAndNil(dataMain.UserIni);
  end;

end.
