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

{$IFNDEF CLR}

{$I LiteDac.inc}
unit LiteFunctionUni;
{$ENDIF}

interface

uses
  SysUtils, Types, Classes, DB, Variants,
{$IFDEF CLR}
  System.Text, System.Runtime.InteropServices,
{$ELSE}
  CLRClasses,
{$ENDIF}
  CRTypes, CRAccess, DAConsts, MemUtils,
{$IFNDEF UNIDACPRO}
  LiteCall, LiteError;
{$ELSE}
  LiteCallUni, LiteErrorUni;
{$ENDIF}

type

  TVariants = array of Variant;

  TLiteFunction = function(InValues: array of Variant): Variant;
  TLiteFunctionMethod = procedure(InValues: array of Variant; var ResultValue: Variant) of object;

  TCustomLiteFunctionDesc = class
  private
    FConnection: TCRConnection;
    FName: string;
    FParamCount: Integer;
    FTextRepresentation: Integer;
  protected
    procedure RegisterFunction;
    procedure UnregisterFunction;

    function GetInParams(Context: pSQLite3Context; ParamCount: Integer; pData: IntPtr): TVariants;
    procedure SetResult(Context: pSQLite3Context; Value: Variant);

    procedure DoFunction(Context: pSQLite3Context; ParamCount: Integer; pData: IntPtr); virtual; abstract;
  public
    constructor Create(Connection: TCRConnection; Name: string; ParamCount: Integer);
    destructor Destroy; override;

    property Name: string read FName;
    property ParamCount: Integer read FParamCount;
    property TextRepresentation: Integer read FTextRepresentation;
  end;

  TLiteFunctionDesc = class(TCustomLiteFunctionDesc)
  private
    FLiteFunction: TLiteFunction;
    FLiteFunctionMethod: TLiteFunctionMethod;
  protected
    procedure DoFunction(Context: pSQLite3Context; ParamCount: Integer; pData: IntPtr); override;
  public
    constructor Create(Connection: TCRConnection; Name: string; ParamCount: Integer; LiteFunction: TLiteFunction); overload;
    constructor Create(Connection: TCRConnection; Name: string; ParamCount: Integer; LiteFunctionMethod: TLiteFunctionMethod); overload;

    property LiteFunction: TLiteFunction read FLiteFunction write FLiteFunction;
  end;

  TSQLiteFunctionManager = class
  private
    {$IFDEF AUTOREFCOUNT}[weak]{$ENDIF}
    FConnection: TCRConnection;
    FFunctionList: TDAObjectList;

  protected
    procedure InternalAddFunction(LiteFunctionDesc: TCustomLiteFunctionDesc);
    procedure InternalRemoveFunction(LiteFunctionDesc: TCustomLiteFunctionDesc);

    function FindFunction(Name: string; ParamCount: Integer): TCustomLiteFunctionDesc;

  public
    constructor Create(Connection: TCRConnection);
    destructor Destroy; override;

    procedure RegisterFunction(Name: string; ParamCount: Integer; LiteFunction: TLiteFunction); overload;
    procedure RegisterFunction(Name: string; ParamCount: Integer; LiteFunctionMethod: TLiteFunctionMethod); overload;
    procedure UnRegisterFunction(Name: string; ParamCount: Integer);

    procedure RegistrAllFunctions;
    procedure UnRegistrAllFunctions;
  end;

implementation

uses
  CRFunctions,
{$IFNDEF UNIDACPRO}
  LiteClasses;
{$ELSE}
  LiteClassesUni;
{$ENDIF}

var
  CallBackLiteFunctionCode : array[0..23] of byte =
   ($55,
    $8B, $EC,

    $8B, $45, $10, $50,
    $8B, $45, $C, $50,
    $8B, $45, $8, $50,

    $B8, $00, $00, $00, $00,
    $FF, $D0,

    $5D,
    $C3);

  CallBackLiteFunctionPtr: IntPtr;
{$IFDEF CLR}
  HCallBackLiteFunction: GCHandle;
  CallBackLiteFunctionRec: packed record
    Ptr: TCallBackLiteFunction;
  end;
  CallbackRecPtr: IntPtr;
{$ENDIF}

{ Function }

procedure CallBackLiteFunction(Context: pSQLite3Context;
                               ParamCount: Integer;
                               pData: IntPtr
                              ); {$IFNDEF CLR}cdecl;{$ENDIF}
var
{$IFDEF CLR}
  pFunc: IntPtr;
{$ELSE}
  pFunc: pFuncDef;
{$ENDIF}
  pUserData: IntPtr;
  functionDesc: TCustomLiteFunctionDesc;
begin
  if Context = nil then
    Exit;
{$IFDEF CLR}
  pFunc := Marshal.ReadIntPtr(Context, 0);
{$ELSE}
  pFunc := Context^.pFunc;
{$ENDIF}
  if pFunc = nil then
    Exit;

{$IFDEF CLR}
  pUserData := Marshal.ReadIntPtr(pFunc, SizeOf(i16) + SizeOf(u8) + SizeOf(u8));
{$ELSE}
  pUserData := pFunc^.pUserData;
{$ENDIF}

{$IFNDEF CLR}
  functionDesc := TCustomLiteFunctionDesc(pUserData);
{$ELSE}
  functionDesc := TCustomLiteFunctionDesc(GCHandle(pUserData).Target);
{$ENDIF}
  functionDesc.DoFunction(Context, ParamCount, pData);
end;

{ TCustomLiteFunctionDesc }

constructor TCustomLiteFunctionDesc.Create(Connection: TCRConnection; Name: string; ParamCount: Integer);
begin
  inherited Create;

  FConnection := Connection;
  FName := Name;
  FParamCount := ParamCount;

  if TSQLiteConnection(FConnection).IsUnicodeDataBase then
    FTextRepresentation := SQLITE_UTF16
  else
    FTextRepresentation := SQLITE_UTF8;
end;

destructor TCustomLiteFunctionDesc.Destroy;
begin
  inherited;
end;

procedure TCustomLiteFunctionDesc.RegisterFunction;
var
  pName: {$IFNDEF CLR}PAnsiChar{$ELSE}IntPtr{$ENDIF};
  pSelf: IntPtr;
  sa: AnsiString;
begin
{$IFNDEF CLR}
  pSelf := Self;
{$ELSE}
  pSelf := IntPtr(GCHandle.Alloc(Self, GCHandleType.Normal));
{$ENDIF}
  sa := TSQLiteConnection(FConnection).EncodeString(Name);
  pName := Marshal.StringToHGlobalAnsi(sa);
  try
  TSQLiteConnection(FConnection).API.sqlite3_create_function(TSQLiteConnection(FConnection).API.SQLite, pName, ParamCount, TextRepresentation, pSelf, CallBackLiteFunctionPtr, nil, nil);

  finally
    Marshal.FreeCoTaskMem(pName);
  end;
end;

procedure TCustomLiteFunctionDesc.UnregisterFunction;
var
  pName: {$IFNDEF CLR}PAnsiChar{$ELSE}IntPtr{$ENDIF};
  sa: AnsiString;
begin
  if FConnection.GetConnected then begin
    sa := TSQLiteConnection(FConnection).EncodeString(Name);
    pName := Marshal.StringToHGlobalAnsi(sa);
    try
    TSQLiteConnection(FConnection).API.sqlite3_create_function(TSQLiteConnection(FConnection).API.SQLite, pName, ParamCount, TextRepresentation, nil, nil, nil, nil);

    finally
      Marshal.FreeCoTaskMem(pName);
    end;
  end;
end;

function TCustomLiteFunctionDesc.GetInParams(Context: pSQLite3Context; ParamCount: Integer; pData: IntPtr): TVariants;
var
  i: integer;
  liteConnection: TSQLiteConnection;
  ParamType: Integer;
  ParamSize: Integer;
  pParam: IntPtr;
  aStrParam: AnsiString;
  wStrParam: WideString;
  blobData: TBytes;
begin
  SetLength(Result, ParamCount);

  liteConnection := TSQLiteConnection(FConnection);
  for i := 0 to ParamCount - 1 do begin
    pParam := Marshal.ReadIntPtr(pData, i * sizeof(IntPtr));
    ParamType := liteConnection.API.sqlite3_value_type(pParam);

    case ParamType of
      SQLITE_INTEGER:
        Result[i] := liteConnection.API.sqlite3_value_int64(pParam);
      SQLITE_FLOAT:
        Result[i] := liteConnection.API.sqlite3_value_double(pParam);
      SQLITE_TEXT:
        if liteConnection.IsUnicodeDataBase then begin
          ParamSize := liteConnection.API.sqlite3_value_bytes16(pParam);
          wStrParam := Marshal.PtrToStringUni(liteConnection.API.sqlite3_value_text16(pParam), ParamSize shr 1);
          if liteConnection.UseUnicode then
            Result[i] := wStrParam
          else
            Result[i] := AnsiString(wStrParam);
        end
        else begin
          ParamSize := liteConnection.API.sqlite3_value_bytes(pParam);
          aStrParam := Marshal.PtrToStringAnsi(liteConnection.API.sqlite3_value_text(pParam), ParamSize);
          Result[i] := aStrParam;
        end;
      SQLITE_BLOB: begin
        ParamSize := liteConnection.API.sqlite3_value_bytes(pParam);
        SetLength(blobData, ParamSize);
        Marshal.Copy(liteConnection.API.sqlite3_value_blob(pParam), blobData, 0, ParamSize);
        Result[i] := blobData;
      end;
      SQLITE_NULL:
        Result[i] := null;
    else
      raise Exception.Create(SUnknownDataType);
    end;
  end;
end;

procedure TCustomLiteFunctionDesc.SetResult(Context: pSQLite3Context; Value: Variant);
var
  liteConnection: TSQLiteConnection;
  liteType: Integer;
  needConvertToText: boolean;
  intValue: Integer;
  floatValue: Double;
  aStrValue: AnsiString;
  pStrValue: IntPtr;
{$IFDEF CLR}
  blobValue: TBytes;
{$ENDIF}
  pBlobValue: IntPtr;
  pDestrType: IntPtr;
begin
  liteConnection := TSQLiteConnection(FConnection);

  if VarType(Value) = varNull then begin
    liteConnection.API.sqlite3_result_null(Context);
    exit;
  end;

  liteType := liteConnection.GetTypes.GetSQLiteType(liteConnection.GetTypes.GetVarType(VarType(Value)), needConvertToText);

  case liteType of
    SQLITE_INTEGER: begin
      intValue := Value;
      liteConnection.API.sqlite3_result_int64(Context, intValue);
    end;
    SQLITE_FLOAT: begin
      floatValue := Value;
      liteConnection.API.sqlite3_result_double(Context, floatValue);
    end;
    SQLITE_TEXT: begin
      if needConvertToText then
        aStrValue := liteConnection.GetTypes.ConvertToText(liteConnection.GetTypes.GetVarType(VarType(Value)), Value)
      else
        aStrValue := liteConnection.GetTypes.ConvertMemo(Value);

      pStrValue := Marshal.StringToHGlobalAnsi(aStrValue);
      try
        liteConnection.API.sqlite3_result_text(Context, pStrValue, LengthA(aStrValue), SQLITE_TRANSIENT);
      finally
        FreeString(pStrValue);
      end;
    end;
    SQLITE_BLOB: begin
    {$IFNDEF CLR}
      pBlobValue := liteConnection.GetTypes.ConvertBlob(Value, pDestrType);
      liteConnection.API.sqlite3_result_blob(Context, pBlobValue, Length(TBytes(pBlobValue)), pDestrType);
    {$ELSE}
      blobValue := liteConnection.GetTypes.ConvertBlob(Value, pDestrType);
      pBlobValue := Marshal.AllocHGlobal(Length(blobValue));
      Marshal.Copy(blobValue, 0, pBlobValue, Length(blobValue));
      try
        liteConnection.API.sqlite3_result_blob(Context, pBlobValue, Length(blobValue), pDestrType);
      finally
        Marshal.FreeHGlobal(pBlobValue);
      end;
    {$ENDIF}
    end;
    SQLITE_NULL:
      liteConnection.API.sqlite3_result_null(Context);
  else
    raise Exception.Create(SUnknownDataType);
  end;
end;

{ TLiteFunctionDesc }

constructor TLiteFunctionDesc.Create(Connection: TCRConnection; Name: string; ParamCount: Integer; LiteFunction: TLiteFunction);
begin
  inherited Create(Connection, Name, ParamCount);
  FLiteFunction := LiteFunction;
end;

constructor TLiteFunctionDesc.Create(Connection: TCRConnection; Name: string;
  ParamCount: Integer; LiteFunctionMethod: TLiteFunctionMethod);
begin
  inherited Create(Connection, Name, ParamCount);
  FLiteFunctionMethod := LiteFunctionMethod;
end;

procedure TLiteFunctionDesc.DoFunction(Context: pSQLite3Context; ParamCount: Integer; pData: IntPtr);
var
  ResultValue: Variant;
begin
  if Assigned(FLiteFunctionMethod) then begin
    FLiteFunctionMethod(GetInParams(Context, ParamCount, pData), ResultValue);
    SetResult(Context, ResultValue);
  end
  else begin
    ResultValue := FLiteFunction(GetInParams(Context, ParamCount, pData));
    SetResult(Context, ResultValue);
  end;
end;

{ TSQLiteFunctionManager }

constructor TSQLiteFunctionManager.Create(Connection: TCRConnection);
begin
  inherited Create;
  FConnection := Connection;
  FFunctionList := TDAObjectList.Create;
end;

destructor TSQLiteFunctionManager.Destroy;
begin
  UnRegistrAllFunctions;
  FFunctionList.Free;
  inherited;
end;

procedure TSQLiteFunctionManager.InternalAddFunction(LiteFunctionDesc: TCustomLiteFunctionDesc);
var
  ExistLiteFunctionDesc: TCustomLiteFunctionDesc;
begin
  ExistLiteFunctionDesc := FindFunction(LiteFunctionDesc.Name, LiteFunctionDesc.ParamCount);
  if ExistLiteFunctionDesc <> nil then
    InternalRemoveFunction(ExistLiteFunctionDesc);

  LiteFunctionDesc.RegisterFunction;
  FFunctionList.Add(LiteFunctionDesc);
end;

procedure TSQLiteFunctionManager.InternalRemoveFunction(LiteFunctionDesc: TCustomLiteFunctionDesc);
begin
  LiteFunctionDesc.UnregisterFunction;
  FFunctionList.Remove(LiteFunctionDesc);
end;

function TSQLiteFunctionManager.FindFunction(Name: string; ParamCount: Integer): TCustomLiteFunctionDesc;
var
  i: integer;
begin
  for i := 0 to FFunctionList.Count - 1 do
  begin
    Result := TCustomLiteFunctionDesc(FFunctionList[i]);
    if (Result.Name = Name) and (Result.ParamCount = ParamCount) then
      exit;
  end;

  // if not found
  Result := nil;
end;

procedure TSQLiteFunctionManager.UnRegistrAllFunctions;
var
  i: integer;
  isConnected: boolean;
begin
  isConnected := FConnection.GetConnected;

  // unregister Functions
  for i := 0 to FFunctionList.Count - 1 do
    if isConnected then
      TCustomLiteFunctionDesc(FFunctionList[i]).UnregisterFunction;
  FFunctionList.Clear;
end;

procedure TSQLiteFunctionManager.RegisterFunction(Name: string; ParamCount: Integer; LiteFunction: TLiteFunction);
var
  LiteFunctionDesc: TCustomLiteFunctionDesc;
begin
  LiteFunctionDesc := TLiteFunctionDesc.Create(FConnection, Name, ParamCount, LiteFunction);
  InternalAddFunction(LiteFunctionDesc);
end;

procedure TSQLiteFunctionManager.RegisterFunction(Name: string;
  ParamCount: Integer; LiteFunctionMethod: TLiteFunctionMethod);
var
  LiteFunctionDesc: TCustomLiteFunctionDesc;
begin
  LiteFunctionDesc := TLiteFunctionDesc.Create(FConnection, Name, ParamCount, LiteFunctionMethod);
  InternalAddFunction(LiteFunctionDesc);
end;

procedure TSQLiteFunctionManager.RegistrAllFunctions;
var
  i: integer;
  isConnected: boolean;
begin
  isConnected := FConnection.GetConnected;

  for i := 0 to FFunctionList.Count - 1 do begin
    if isConnected then
      TCustomLiteFunctionDesc(FFunctionList[i]).RegisterFunction;
  end;
end;

procedure TSQLiteFunctionManager.UnRegisterFunction(Name: string; ParamCount: Integer);
var
  LiteFunctionDesc: TCustomLiteFunctionDesc;
begin
  LiteFunctionDesc := FindFunction(Name, ParamCount);
  if LiteFunctionDesc <> nil then
    InternalRemoveFunction(LiteFunctionDesc);
end;

initialization
{$IFNDEF CLR}
  CallBackLiteFunctionPtr := @CallBackLiteFunction;
{$ELSE}
  CallBackLiteFunctionPtr := Marshal.AllocHGlobal(Length(CallBackLiteFunctionCode));
  Marshal.Copy(TBytes(CallBackLiteFunctionCode), 0, CallBackLiteFunctionPtr, Length(CallBackLiteFunctionCode));

  CallbackRecPtr := Marshal.AllocHGlobal(20);
  try
    CallBackLiteFunctionRec.Ptr := CallBackLiteFunction;
    HCallBackLiteFunction := GCHandle.Alloc(@CallBackLiteFunctionRec.Ptr, GCHandleType.Normal);
    Marshal.StructureToPtr(CallBackLiteFunctionRec, CallbackRecPtr, False);
    Marshal.WriteIntPtr(CallBackLiteFunctionPtr, 16, Marshal.ReadIntPtr(CallbackRecPtr));
  finally
    Marshal.FreeHGlobal(CallbackRecPtr);
  end;
{$ENDIF}

finalization
{$IFNDEF CLR}
  CallBackLiteFunctionPtr := nil;
{$ELSE}
  HCallBackLiteFunction.Free;
  Marshal.FreeHGlobal(CallBackLiteFunctionPtr);
{$ENDIF}

end.
