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

{$IFNDEF CLR}

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

interface

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

type
  TLiteCollation = function(Str1, Str2: string): Integer;
  TLiteCollationMethod = function(const Str1, Str2: string): Integer of object;

  TLiteAnsiCollation = function(Str1, Str2: AnsiString): Integer;
  TLiteAnsiCollationMethod = function(Str1, Str2: AnsiString): Integer of object;

  TLiteWideCollation = function(Str1, Str2: WideString): Integer;
  TLiteWideCollationMethod = function(Str1, Str2: WideString): Integer of object;

  TCustomLiteCollationDesc = class
  private
    {$IFDEF AUTOREFCOUNT}[weak]{$ENDIF}
    FConnection: TCRConnection;
    FName: string;
    FTextRepresentation: Integer;
  protected
    procedure RegisterCollation;
    procedure UnregisterCollation;

    function GetAnsiStr(StrSize: Integer; const pStr: IntPtr): AnsiString;
    function GetWideStr(StrSize: Integer; const pStr: IntPtr): WideString;

    function DoCollate(StrSize1: Integer; const pStr1: IntPtr; StrSize2: Integer; const pStr2: IntPtr): Integer; virtual; abstract;
  public
    constructor Create(Connection: TCRConnection; Name: string); overload;
    destructor Destroy; override;

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

  TLiteCollationDesc = class(TCustomLiteCollationDesc)
  private
    FLiteCollation: TLiteCollation;
    FLiteCollationMethod: TLiteCollationMethod;
  protected
    function DoCollate(StrSize1: Integer; const pStr1: IntPtr; StrSize2: Integer; const pStr2: IntPtr): Integer; override;
  public
    constructor Create(Connection: TCRConnection; Name: string; LiteCollation: TLiteCollation); overload;
    constructor Create(Connection: TCRConnection; Name: string; LiteCollation: TLiteCollationMethod); overload;

    property LiteCollation: TLiteCollation read FLiteCollation write FLiteCollation;
  end;

  TLiteAnsiCollationDesc = class(TCustomLiteCollationDesc)
  private
    FLiteAnsiCollation: TLiteAnsiCollation;
  protected
    function DoCollate(StrSize1: Integer; const pStr1: IntPtr; StrSize2: Integer; const pStr2: IntPtr): Integer; override;
  public
    constructor Create(Connection: TCRConnection; Name: string; LiteAnsiCollation: TLiteAnsiCollation); overload;

    property LiteAnsiCollation: TLiteAnsiCollation read FLiteAnsiCollation write FLiteAnsiCollation;
  end;

  TLiteWideCollationDesc = class(TCustomLiteCollationDesc)
  private
    FLiteWideCollation: TLiteWideCollation;
  protected
    function DoCollate(StrSize1: Integer; const pStr1: IntPtr; StrSize2: Integer; const pStr2: IntPtr): Integer; override;
  public
    constructor Create(Connection: TCRConnection; Name: string; LiteWideCollation: TLiteWideCollation); overload;

    property LiteWideCollation: TLiteWideCollation read FLiteWideCollation write FLiteWideCollation;
  end;

  TSQLiteCollationManager = class
  private
    {$IFDEF AUTOREFCOUNT}[weak]{$ENDIF}
    FConnection: TCRConnection;
    FCollationList: TDAObjectList;
  protected
    procedure InternalAddCollation(LiteCollationDesc: TCustomLiteCollationDesc);
    procedure InternalRemoveCollation(LiteCollationDesc: TCustomLiteCollationDesc);

    function FindCollation(Name: string): TCustomLiteCollationDesc;
    procedure UnRegistrAllCollations;
  public
    constructor Create(Connection: TCRConnection);
    destructor Destroy; override;

    procedure RegisterCollation(Name: string; LiteCollation: TLiteCollation); overload;
    procedure RegisterCollation(Name: string; LiteCollation: TLiteCollationMethod); overload;
    procedure UnRegisterCollation(Name: string);

    procedure RegisterAnsiCollation(Name: string; LiteAnsiCollation: TLiteAnsiCollation);
    procedure UnRegisterAnsiCollation(Name: string);

    procedure RegisterWideCollation(Name: string; LiteWideCollation: TLiteWideCollation);
    procedure UnRegisterWideCollation(Name: string);

    procedure RegisterDefaultCollations;
    procedure UnRegisterDefaultCollations;
  end;

implementation

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

var
  CallBackLiteCollationCode : array[0..39] of byte =
   ($55,
    $8B, $EC,
    $51,
    $8B, $45, $18, $50,
    $8B, $45, $14, $50,
    $8B, $45, $10, $50,
    $8B, $45, $C, $50,
    $8B, $45, $8, $50,

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

    $89, $45, $FC,
    $8B, $45, $FC,

    $59,
    $5D,
    $C3);

  CallBackLiteCollationPtr: IntPtr;
{$IFDEF CLR}
  HCallBackLiteCollation: GCHandle;
  CallBackLiteCollationRec: packed record
    Ptr: TCallBackLiteCollation;
  end;
  CallbackRecPtr: IntPtr;
{$ENDIF}

{ Function }

function CallBackLiteCollation(pUserData: IntPtr;
                               StrSize1: Integer; const pStr1: IntPtr;
                               StrSize2: Integer; const pStr2: IntPtr
                              ): Integer; {$IFNDEF CLR}cdecl;{$ENDIF}
var
  collationDesc: TCustomLiteCollationDesc;
begin
{$IFNDEF CLR}
  collationDesc := TCustomLiteCollationDesc(pUserData);
{$ELSE}
  collationDesc := TCustomLiteCollationDesc(GCHandle(pUserData).Target);
{$ENDIF}
  Result := collationDesc.DoCollate(StrSize1, pStr1, StrSize2, pStr2);
end;

function DefaultUnicodeNoCase(WStr1, WStr2: WideString): Integer;
var
  upperStr1: WideString;
  upperStr2: WideString;
begin
  upperStr1 := {$IFNDEF NEXTGEN}WideUpperCase{$ELSE}UpperCase{$ENDIF}(WStr1);
  upperStr2 := {$IFNDEF NEXTGEN}WideUpperCase{$ELSE}UpperCase{$ENDIF}(WStr2);

  if upperStr1 > upperStr2 then
    Result := 1
  else if upperStr1 < upperStr2 then
    Result := -1
  else
    Result :=  0;
end;

{ TCustomLiteCollationDesc }

constructor TCustomLiteCollationDesc.Create(Connection: TCRConnection; Name: string);
begin
  inherited Create;

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

destructor TCustomLiteCollationDesc.Destroy;
begin
  inherited;
end;

procedure TCustomLiteCollationDesc.RegisterCollation;
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 := AnsiString(Name);
  pName := Marshal.StringToHGlobalAnsi(sa);
  try

  TSQLiteConnection(FConnection).API.sqlite3_create_collation(TSQLiteConnection(FConnection).API.SQLite, pName, FTextRepresentation, pSelf, CallBackLiteCollationPtr);

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

procedure TCustomLiteCollationDesc.UnregisterCollation;
var
  pName: {$IFNDEF CLR}PAnsiChar{$ELSE}IntPtr{$ENDIF};
  sa: AnsiString;
begin
  if FConnection.GetConnected then begin
    sa := AnsiString(Name);
    pName := Marshal.StringToHGlobalAnsi(sa);
    try
      TSQLiteConnection(FConnection).API.sqlite3_create_collation(TSQLiteConnection(FConnection).API.SQLite, pName, FTextRepresentation, nil, nil);
    finally
      Marshal.FreeCoTaskMem(pName);
    end;
  end;
end;

function TCustomLiteCollationDesc.GetAnsiStr(StrSize: Integer; const pStr: IntPtr): AnsiString;
begin
  Result := Marshal.PtrToStringAnsi(pStr, StrSize);
end;

function TCustomLiteCollationDesc.GetWideStr(StrSize: Integer; const pStr: IntPtr): WideString;
begin
  Result := Marshal.PtrToStringUni(pStr, StrSize shr 1);
end;

{ TLiteCollationDesc }

constructor TLiteCollationDesc.Create(Connection: TCRConnection; Name: string; LiteCollation: TLiteCollation);
begin
  inherited Create(Connection, Name);
  FLiteCollation := LiteCollation;
end;

constructor TLiteCollationDesc.Create(Connection: TCRConnection; Name: string; LiteCollation: TLiteCollationMethod);
begin
  inherited Create(Connection, Name);
  FLiteCollationMethod := LiteCollation;
end;

function TLiteCollationDesc.DoCollate(StrSize1: Integer; const pStr1: IntPtr;
                                      StrSize2: Integer; const pStr2: IntPtr): Integer;
begin
  if TSQLiteConnection(FConnection).IsUnicodeDataBase then begin
    if Assigned(FLiteCollationMethod) then
      Result := FLiteCollationMethod(string(GetWideStr(StrSize1, pStr1)), string(GetWideStr(StrSize2, pStr2)))
    else
      Result := FLiteCollation(string(GetWideStr(StrSize1, pStr1)), string(GetWideStr(StrSize2, pStr2)));
  end
  else begin
    if Assigned(FLiteCollationMethod) then
      Result := FLiteCollationMethod(string(GetAnsiStr(StrSize1, pStr1)), string(GetAnsiStr(StrSize2, pStr2)))
    else
      Result := FLiteCollation(string(GetAnsiStr(StrSize1, pStr1)), string(GetAnsiStr(StrSize2, pStr2)));
  end;
end;

{ TLiteAnsiCollationDesc }

constructor TLiteAnsiCollationDesc.Create(Connection: TCRConnection; Name: string; LiteAnsiCollation: TLiteAnsiCollation);
begin
  inherited Create(Connection, Name);
  FLiteAnsiCollation := LiteAnsiCollation;
end;

function TLiteAnsiCollationDesc.DoCollate(StrSize1: Integer; const pStr1: IntPtr;
                                          StrSize2: Integer; const pStr2: IntPtr): Integer;
begin
  if TSQLiteConnection(FConnection).IsUnicodeDataBase then
    Result := FLiteAnsiCollation(AnsiString(GetWideStr(StrSize1, pStr1)), AnsiString(GetWideStr(StrSize2, pStr2)))
  else
    Result := FLiteAnsiCollation(GetAnsiStr(StrSize1, pStr1), GetAnsiStr(StrSize2, pStr2));
end;

{ TLiteWideCollationDesc }

constructor TLiteWideCollationDesc.Create(Connection: TCRConnection; Name: string; LiteWideCollation: TLiteWideCollation);
begin
  inherited Create(Connection, Name);
  FLiteWideCollation := LiteWideCollation;
end;

function TLiteWideCollationDesc.DoCollate(StrSize1: Integer; const pStr1: IntPtr;
                                          StrSize2: Integer; const pStr2: IntPtr): Integer;
begin
  if TSQLiteConnection(FConnection).IsUnicodeDataBase then
    Result := FLiteWideCollation(GetWideStr(StrSize1, pStr1), GetWideStr(StrSize2, pStr2))
  else
    Result := FLiteWideCollation(WideString(GetAnsiStr(StrSize1, pStr1)), WideString(GetAnsiStr(StrSize2, pStr2)));
end;

{ TSQLiteCollationManager }

constructor TSQLiteCollationManager.Create(Connection: TCRConnection);
begin
  inherited Create;

  FConnection := Connection;
  FCollationList := TDAObjectList.Create;
end;

destructor TSQLiteCollationManager.Destroy;
begin
  UnRegistrAllCollations;
  FCollationList.Free;

  inherited;
end;

procedure TSQLiteCollationManager.InternalAddCollation(LiteCollationDesc: TCustomLiteCollationDesc);
var
  ExistLiteCollationDesc: TCustomLiteCollationDesc;
begin
  ExistLiteCollationDesc := FindCollation(LiteCollationDesc.Name);
  if ExistLiteCollationDesc <> nil then
    InternalRemoveCollation(ExistLiteCollationDesc);

  LiteCollationDesc.RegisterCollation;
  FCollationList.Add(LiteCollationDesc);
end;

procedure TSQLiteCollationManager.InternalRemoveCollation(LiteCollationDesc: TCustomLiteCollationDesc);
begin
  LiteCollationDesc.UnregisterCollation;
  FCollationList.Remove(LiteCollationDesc);
end;

function TSQLiteCollationManager.FindCollation(Name: string): TCustomLiteCollationDesc;
var
  i: integer;
begin
  for i := 0 to FCollationList.Count - 1 do
  begin
    Result := TCustomLiteCollationDesc(FCollationList[i]);
    if Result.Name = Name then
      exit;
  end;

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

procedure TSQLiteCollationManager.UnRegistrAllCollations;
var
  i: integer;
begin
  // unregister collations
  for i := 0 to FCollationList.Count - 1 do
    TCustomLiteCollationDesc(FCollationList[i]).UnregisterCollation;
  FCollationList.Clear;
end;

procedure TSQLiteCollationManager.RegisterCollation(Name: string; LiteCollation: TLiteCollation);
var
  LiteCollationDesc: TCustomLiteCollationDesc;
begin
  LiteCollationDesc := TLiteCollationDesc.Create(FConnection, Name, LiteCollation);
  InternalAddCollation(LiteCollationDesc);
end;

procedure TSQLiteCollationManager.RegisterCollation(Name: string; LiteCollation: TLiteCollationMethod);
var
  LiteCollationDesc: TCustomLiteCollationDesc;
begin
  LiteCollationDesc := TLiteCollationDesc.Create(FConnection, Name, LiteCollation);
  InternalAddCollation(LiteCollationDesc);
end;

procedure TSQLiteCollationManager.UnRegisterCollation(Name: string);
var
  LiteCollationDesc: TCustomLiteCollationDesc;
begin
  LiteCollationDesc := FindCollation(Name);
  if LiteCollationDesc <> nil then
    InternalRemoveCollation(LiteCollationDesc);
end;

procedure TSQLiteCollationManager.RegisterAnsiCollation(Name: string; LiteAnsiCollation: TLiteAnsiCollation);
var
  LiteCollationDesc: TCustomLiteCollationDesc;
begin
  LiteCollationDesc := TLiteAnsiCollationDesc.Create(FConnection, Name, LiteAnsiCollation);
  InternalAddCollation(LiteCollationDesc);
end;

procedure TSQLiteCollationManager.UnRegisterAnsiCollation(Name: string);
var
  LiteCollationDesc: TCustomLiteCollationDesc;
begin
  LiteCollationDesc := FindCollation(Name);
  if LiteCollationDesc <> nil then
    InternalRemoveCollation(LiteCollationDesc);
end;

procedure TSQLiteCollationManager.RegisterWideCollation(Name: string; LiteWideCollation: TLiteWideCollation);
var
  LiteCollationDesc: TCustomLiteCollationDesc;
begin
  LiteCollationDesc := TLiteWideCollationDesc.Create(FConnection, Name, LiteWideCollation);
  InternalAddCollation(LiteCollationDesc);
end;

procedure TSQLiteCollationManager.UnRegisterWideCollation(Name: string);
var
  LiteCollationDesc: TCustomLiteCollationDesc;
begin
  LiteCollationDesc := FindCollation(Name);
  if LiteCollationDesc <> nil then
    InternalRemoveCollation(LiteCollationDesc);
end;

procedure TSQLiteCollationManager.RegisterDefaultCollations;
begin
  RegisterWideCollation('UniNoCase', DefaultUnicodeNoCase);
end;

procedure TSQLiteCollationManager.UnRegisterDefaultCollations;
begin
  UnRegisterWideCollation('UniNoCase');
end;

initialization
{$IFNDEF CLR}
  CallBackLiteCollationPtr := @CallBackLiteCollation;
{$ELSE}
  CallBackLiteCollationPtr := Marshal.AllocHGlobal(Length(CallBackLiteCollationCode));
  Marshal.Copy(TBytes(CallBackLiteCollationCode), 0, CallBackLiteCollationPtr, Length(CallBackLiteCollationCode));

  CallbackRecPtr := Marshal.AllocHGlobal(20);
  try
    CallBackLiteCollationRec.Ptr := CallBackLiteCollation;
    HCallBackLiteCollation := GCHandle.Alloc(@CallBackLiteCollationRec.Ptr, GCHandleType.Normal);
    Marshal.StructureToPtr(CallBackLiteCollationRec, CallbackRecPtr, False);
    Marshal.WriteIntPtr(CallBackLiteCollationPtr, 25, Marshal.ReadIntPtr(CallbackRecPtr));
  finally
    Marshal.FreeHGlobal(CallbackRecPtr);
  end;
{$ENDIF}

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

end.
