
//////////////////////////////////////////////////
//  ASE Data Access Components
//  Copyright © 2008-2014 Devart. All right reserved.
//////////////////////////////////////////////////

{$IFNDEF CLR}

{$I ASEDac.inc}
unit ASEClassesUni;
{$ENDIF}

interface

uses
{$IFDEF MSWINDOWS}
  Windows,
{$ENDIF}
{$IFDEF CLR}
  System.Text, System.Runtime.InteropServices,
{$ELSE}
  CLRClasses,
{$ENDIF}
  Classes, SysUtils, Variants, SyncObjs,
{$IFNDEF FPC}
  FMTBcd,
{$ENDIF}
{$IFDEF VER12P}
  AnsiStrings,
{$ENDIF}
  CRTypes, MemData, CRAccess, CRParser, CRDataTypeMap,
{$IFNDEF UNIDACPRO}
  ODBCCall, ODBCClasses, ASEParser;
{$ELSE}
  ODBCCallUni, ODBCClassesUni, ASEParserUni;
{$ENDIF}

const
  prASEBase = 2000;
  prAnsiNull = prASEBase + 1;
  prApplicationName = prASEBase + 2;
  prSelectMethod = prASEBase + 3;
  prEncryptPassword = prASEBase + 4;
  prPrepareMethod = prASEBase + 5;

type
  TASESelectMethod = (smCursor, smDirect);
  TASEEncryptPassword = (epDisable, epRequire, epPrefer);
  TASEPrepareMethod = (pmNone, pmPartial, pmFull, pmFullatPrepare);

{ TASEConnection }

  TASEConnection = class(TODBCConnection)
  private
    FDatabase: string;
    FPort: integer;
//    FDriverType: TASEDriverType;
    FAnsiNull: Boolean;
    FServiceConnection: TASEConnection;
    FApplicationName: string;
    FSelectMethod: TASESelectMethod;
    FEncryptPassword: TASEEncryptPassword;
    FPreparedMethod: TASEPrepareMethod;
    procedure SetAnsiNull(const Value: boolean);

  protected
    function GetConnectionString: string; override;
    function OutParamIsInOut: boolean; override;
    procedure SetDatabase(const Value: string);
    procedure InternalSetAnsiNull(const Value: boolean);

  public
    constructor Create; override;
    destructor Destroy; override;

    function GetCommandClass: TCRCommandClass; override;
    function GetTransactionClass: TCRTransactionClass; override;

    procedure Connect(const ConnectString: string); override;
    procedure Disconnect; override;
    function GetServiceConnection: TASEConnection;

    function SetProp(Prop: integer; const Value: variant): boolean; override;
    function GetProp(Prop: integer; out Value: variant): boolean; override;

    procedure Assign(Source: TCRConnection); override;
    function CanChangeDatabase: boolean; override;
    function GetCurrentCatalog: string; override;
    function GetCachedCatalog: string; override;
    function GetCurrentSchema: string; override;
  end;

{ TASETransaction }

  TASETransaction = class(TODBCTransaction)
  public
    procedure Savepoint(const Name: string); override;
    procedure ReleaseSavepoint(const Name: string); override;
    procedure RollbackToSavepoint(const Name: string); override;
  end;

{ TASEParamDesc }

  TASEParamDesc = class (TODBCParamDesc)
  public
    constructor Create; override;
  end;

{ TASESQLInfo }

  TASESQLInfo = class(TODBCSQLInfo)
  public
    function LeftQuote: char; override;
    function RightQuote: char; override;
  end;

{ TASECommand }

  TASECommand = class(TODBCCommand)
  protected
    procedure SetSpecificParamPrec(Param: TODBCParamDesc; var Prec, Scale: integer); override;
    function DetectSpecificType(const TypeName: string; var SQLLength: Integer; var SQLScale: SmallInt): integer; override;
  public
    class function GetSQLInfoClass: TSQLInfoClass; override;
    class function GetParserClass: TSQLParserClass; override;
    class function GetMapRulesClass: TCRMapRulesClass; override;
    function GetParamDescType: TParamDescClass; override;
  end;

{ TASERecordSet }

  TASERecordSet = class(TODBCRecordSet)
  protected
    procedure CreateCommand; override;
  end;

{ TASEMetaData }

  TASEMetaData = class(TODBCMetaData)
  protected
    FRecordSet2: TASERecordSet;

    procedure InternalGetMetaDataKindsList(List: TStringList); override;

    function GetDatabases(Restrictions: TStrings): TData; override;
  public
    constructor Create; override;
    destructor Destroy; override;
  end;

{$IFNDEF LITE}

{ TASELoader }

  TASELoader = class (TODBCLoader)
  protected
    procedure CreateCommand; override;
    class function GetRecordSetClass: TCRRecordSetClass; override;
  end;
{$ENDIF}

implementation

uses
  CRFunctions, DAConsts,
{$IFNDEF UNIDACPRO}
  ODBCConsts, ASEDataTypeMap;
{$ELSE}
  ODBCConstsUni, ASEDataTypeMapUni;
{$ENDIF}

{ TASEConnection }

constructor TASEConnection.Create;
begin
  inherited;
  
  FAnsiNull := True; // Set the AnsiNull option to On by default (old behavior)
end;

destructor TASEConnection.Destroy;
begin
  FServiceConnection.Free;
  FServiceConnection := nil;

  inherited;
end;

procedure TASEConnection.SetAnsiNull(const Value: boolean);
begin
  if FAnsiNull <> Value then
  begin
    FAnsiNull := Value;
    if FConnected then
      InternalSetAnsiNull(FAnsiNull);
  end;
end;

function TASEConnection.GetCommandClass: TCRCommandClass;
begin
  Result := TASECommand;
end;

function TASEConnection.GetTransactionClass: TCRTransactionClass;
begin
  Result := TASETransaction;
end;

function TASEConnection.GetConnectionString: string;
var
  Port: integer;
  Server: string;
  Database: string;
  ApplicationName: string;
  SelectMethod: TASESelectMethod;
  EncryptPassword: TASEEncryptPassword;
  PrepareMethod: TASEPrepareMethod;
begin
  Server := Trim(FServer);
  if Server = '' then
    Server := 'localhost';

  Port := FPort;
  if Port = 0 then
    Port := 5000;

  Database := Trim(FDatabase);
  ApplicationName := Trim(FApplicationName);
  SelectMethod := FSelectMethod;
  EncryptPassword := FEncryptPassword;
  PrepareMethod := FPreparedMethod;

  if IsDriverPresent('Adaptive Server Enterprise') then begin
    Result := Format('DRIVER={Adaptive Server Enterprise};UID=%s;PWD=%s;server=%s;port=%d',
      [FUsername, FPassword, Server, Port]);
    if Database <> '' then
      Result := Result + ';database= ' + Database;
    if EncryptPassword = epRequire then
      Result := Result + ';EncryptPassword=1'
    else if EncryptPassword = epPrefer then
      Result := Result + ';EncryptPassword=2'
    else
      Result := Result + ';EncryptPassword=0';
  end
  else begin
    Result := Format('DRIVER={Sybase ASE ODBC Driver};UID=%s;PWD=%s;NA=%s,%d',
      [FUsername, FPassword, Server, Port]);
    if Database <> '' then
      Result := Result + ';DB=' + Database;
    if SelectMethod = smCursor then
      Result := Result + ';SM=1'
    else
      Result := Result + ';SM=0';
    if EncryptPassword in [epRequire, epPrefer] then
      Result := Result + ';PasswordEncryption=1'
    else
      Result := Result + ';PasswordEncryption=0';
    Result := Result + ';OptimizePrepare=';
    case PrepareMethod of
      pmPartial: Result := Result + '1';
      pmFull: Result := Result + '2';
      pmFullatPrepare: Result := Result + '3';
      else
        Result := Result + '0';
    end;
  end;

  if ApplicationName <> '' then
    Result:= Result + ';App= ' + ApplicationName;
end;

function TASEConnection.OutParamIsInOut: boolean;
begin
  Result := True;
end;

procedure TASEConnection.SetDatabase(const Value: string);
begin
  if not FConnected then
    raise Exception.Create(SConnectionIsClosed);

  if Value = '' then
    raise Exception.Create(SWrongDatabaseName);

  ExecSQL('USE ' + FRecordSet.GetCommand.SQLInfo.NormalizeName(Value));
  FDatabase := Value;
  FCachedCatalog := '';
end;

procedure TASEConnection.InternalSetAnsiNull(const Value: boolean);
begin
  if Value then
    ExecSQL('set ansinull on')
  else
    ExecSQL('set ansinull off');
end;

procedure TASEConnection.Connect(const ConnectString: string);
begin
  inherited;

  InternalSetAnsiNull(FAnsiNull);
end;

procedure TASEConnection.Disconnect;
begin
  if FServiceConnection <> nil then
    FServiceConnection.Disconnect;

  inherited;
end;

function TASEConnection.GetServiceConnection;
begin
  if FServiceConnection = nil then
    FServiceConnection := TASEConnection.Create;

  if not FServiceConnection.FConnected then begin
    FServiceConnection.Assign(Self);
    FServiceConnection.Connect('');
  end;

  Result := FServiceConnection;
end;

function TASEConnection.SetProp(Prop: integer; const Value: variant): boolean;
begin
  Result := True;
  case Prop of
    prDatabase: begin
      if Value <> FDatabase then begin
        if GetConnected then
          SetDatabase(Value);
        FDatabase := Value;
      end;
    end;
    prPort:
      FPort := Value;
    prAnsiNull:
      SetAnsiNull(Value);
    prApplicationName:
      FApplicationName := Value;
    prSelectMethod:
      FSelectMethod := TASESelectMethod(Value);
    prEncryptPassword:
      FEncryptPassword := TASEEncryptPassword(Value);
    prPrepareMethod:
      FPreparedMethod := TASEPrepareMethod(Value);
  else
    Result := inherited SetProp(Prop, Value);
  end;
end;

function TASEConnection.GetProp(Prop: integer; out Value: variant): boolean;
begin
  Result := True;
  case Prop of
    prDatabase:
      Value := FDatabase;
    prPort:
      Value := FPort;
    prAnsiNull:
      Value := FAnsiNull;
    prMaxStringSize:
      Value := 1960;
    prApplicationName:
      Value := FApplicationName;
    prSelectMethod:
      Value := Variant(FSelectMethod);
    prEncryptPassword:
      Value := Variant(FEncryptPassword);
    prPrepareMethod:
      Value := Variant(FPreparedMethod);
  else
    Result := inherited GetProp(Prop, Value);
  end;
end;

procedure TASEConnection.Assign(Source: TCRConnection);
begin
  inherited;

  FDatabase := TASEConnection(Source).FDatabase;
  FPort := TASEConnection(Source).FPort;
  FAnsiNull := TASEConnection(Source).FAnsiNull;
  FApplicationName := TASEConnection(Source).FApplicationName;
  FSelectMethod := TASEConnection(Source).FSelectMethod;
  FEncryptPassword := TASEConnection(Source).FEncryptPassword;
  FPreparedMethod := TASEConnection(Source).FPreparedMethod;
end;

function TASEConnection.CanChangeDatabase: boolean;
begin
  Result := True; 
end;

function TASEConnection.GetCurrentCatalog: string;
var
  RecBuf: IntPtr;
  v: variant;
begin
  if not FConnected then
    raise Exception.Create(SConnectionIsClosed);

  CheckRecordSet;
  FRecordSet.SetSQL('SELECT db_name()');
  FRecordSet.Open;
  FRecordSet.AllocRecBuf(RecBuf);
  try
    FRecordSet.GetNextRecord(RecBuf);
    if FRecordSet.Eof then begin
      Result := '';
      exit;
    end;
    FRecordSet.GetFieldAsVariant(FRecordSet.Fields[0], RecBuf, v);
    Result := Trim(VarToStr(v));
    FRecordSet.Close;
  finally
    Marshal.FreeHGlobal(RecBuf);
  end;
end;

function TASEConnection.GetCachedCatalog: string;
begin
  if FCachedCatalog = '' then
    if FDatabase <> '' then
      FCachedCatalog := FRecordSet.GetCommand.SQLInfo.NormalizeName(FDatabase, False, True)
    else
      FCachedCatalog := GetCurrentCatalog;

  Result := FCachedCatalog;
end;

function TASEConnection.GetCurrentSchema: string;
var
  RecBuf: IntPtr;
  v: variant;
begin
  if not FConnected then
    raise Exception.Create(SConnectionIsClosed);

  CheckRecordSet;
  FRecordSet.SetSQL('SELECT USER');
  FRecordSet.Open;
  FRecordSet.AllocRecBuf(RecBuf);
  try
    FRecordSet.GetNextRecord(RecBuf);
    if FRecordSet.Eof then begin
      Result := '';
      exit;
    end;
    FRecordSet.GetFieldAsVariant(FRecordSet.Fields[0], RecBuf, v);
    Result := Trim(VarToStr(v));
    FRecordSet.Close;
  finally
    Marshal.FreeHGlobal(RecBuf);
  end;
end;

{ TASETransaction }

procedure TASETransaction.Savepoint(const Name: string);
var
  Connection: TODBCConnection;
begin
  CheckActive;

  Connection := TODBCConnection(FConnections[0]);
  Connection.ExecSQL('SAVE TRANSACTION ' + Name);
end;

procedure TASETransaction.ReleaseSavepoint(const Name: string);
begin
  raise Exception.Create(SOperationNotSupported);
end;

procedure TASETransaction.RollbackToSavepoint(const Name: string);
var
  Connection: TODBCConnection;
begin
  CheckActive;

  Connection := TODBCConnection(FConnections[0]);
  Connection.ExecSQL('ROLLBACK ' + Name);
end;

{ TASEParamDesc }

constructor TASEParamDesc.Create;
begin
  inherited;
  FEnableMSec := False;
end;

{ TASESQLInfo }

function TASESQLInfo.LeftQuote: char;
begin
  Result := '[';
end;

function TASESQLInfo.RightQuote: char;
begin
  Result := ']';
end;

{ TASECommand }

class function TASECommand.GetSQLInfoClass: TSQLInfoClass;
begin
  Result := TASESQLInfo;
end;

class function TASECommand.GetParserClass: TSQLParserClass;
begin
  Result := TASEParser;
end;

class function TASECommand.GetMapRulesClass: TCRMapRulesClass;
begin
  Result := TASEMapRules;
end;

function TASECommand.GetParamDescType: TParamDescClass;
begin
  Result := TASEParamDesc;
end;

procedure TASECommand.SetSpecificParamPrec(Param: TODBCParamDesc; var Prec, Scale: integer);
begin
  case Param.GetDataType of
    dtDateTime:
      Prec := 19;
    else
      inherited;
  end;
end;

function TASECommand.DetectSpecificType(const TypeName: string; var SQLLength: Integer; var SQLScale: Smallint): integer;
begin
  if UpperCase(TypeName) = 'NUMERIC' then
    Result := SQL_NUMERIC
  else
    Result := inherited DetectSpecificType(TypeName, SQLLength, SQLScale);
end;

{ TASERecordSet }

procedure TASERecordSet.CreateCommand;
begin
  SetCommand(TASECommand.Create);
end;

{ TASEMetaData }

constructor TASEMetaData.Create;
begin
  inherited;

  FRecordSet2 := TASERecordSet.Create;
  FRecordSet2.SetProp(prFetchAll, True);
  FRecordSet2.SetProp(prFlatBuffers, False);
end;

destructor TASEMetaData.Destroy;
begin
  FRecordSet2.Free;

  inherited;
end;

procedure TASEMetaData.InternalGetMetaDataKindsList(List: TStringList);
begin
  inherited;

  List.Add('Databases');
  List.Sort;
end;

function TASEMetaData.GetDatabases(Restrictions: TStrings): TData;
const
  SQL = 'SELECT name AS DATABASE_NAME FROM master.dbo.sysdatabases';
begin
  FRecordSet2.SetConnection(FRecordSet.GetCommand.GetConnection);
  FRecordSet2.SetSQL(SQL);
  FRecordSet2.Open;
  Result := FRecordSet2;
end;

{$IFNDEF LITE}

{ TASELoader }

procedure TASELoader.CreateCommand;
begin
  FCommand := TASECommand.Create;
end;

class function TASELoader.GetRecordSetClass: TCRRecordSetClass;
begin
  Result := TASERecordSet;
end;

{$ENDIF}

end.
