tntdb.pas

Make your Delphi application UNICODE enabled.

procedure TTntDateTimeField.SetAsString(const Value: AnsiString);
begin
  if Value = '' then
    inherited
  else
    SetAsDateTime(TntStrToDateTime(Value));
end;

{ TTntDateField }

procedure TTntDateField.SetAsString(const Value: AnsiString);
begin
  if Value = '' then
    inherited
  else
    SetAsDateTime(TntStrToDate(Value));
end;

{ TTntTimeField }

procedure TTntTimeField.SetAsString(const Value: AnsiString);
begin
  if Value = '' then
    inherited
  else
    SetAsDateTime(TntStrToTime(Value));
end;

{ TTntWideStringField / TTntStringField common handlers }

procedure TntWideStringField_LegacyGetText(Sender: TField; OnGetText: TFieldGetWideTextEvent;
  var AnsiText: AnsiString; DoDisplayText: Boolean);
var
  WideText: WideString;
begin
  if Assigned(OnGetText) then begin
    WideText := AnsiText;
    OnGetText(Sender, WideText, DoDisplayText);
    AnsiText := WideText;
  end;
end;

procedure TntWideStringField_LegacySetText(Sender: TField; OnSetText: TFieldSetWideTextEvent;
  const AnsiText: AnsiString);
begin
  if Assigned(OnSetText) then
    OnSetText(Sender, AnsiText);
end;

procedure TntWideStringField_GetWideText(Field: TField;
  var Text: WideString; DoDisplayText: Boolean);
var
  WideStringField: IWideStringField;
begin
  Field.GetInterface(IWideStringField, WideStringField);
  Assert(WideStringField <> nil);
  if DoDisplayText and (Field.EditMaskPtr <> '') then
    { to gain the mask, we lose Unicode! }
    Text := FormatMaskText(Field.EditMaskPtr, GetAsWideString(Field))
  else
    Text := GetAsWideString(Field);
end;

function TntWideStringField_GetWideDisplayText(Field: TField;
  OnGetText: TFieldGetWideTextEvent): WideString;
begin
  Result := '';
  if Assigned(OnGetText) then
    OnGetText(Field, Result, True)
  else if Assigned(Field.OnGetText) then
    Result := Field.DisplayText{TNT-ALLOW DisplayText} {we lose Unicode to handle this event}
  else
    TntWideStringField_GetWideText(Field, Result, True);
end;

function TntWideStringField_GetWideEditText(Field: TField;
  OnGetText: TFieldGetWideTextEvent): WideString;
begin
  Result := '';
  if Assigned(OnGetText) then
    OnGetText(Field, Result, False)
  else if Assigned(Field.OnGetText) then
    Result := Field.Text {we lose Unicode to handle this event}
  else
    TntWideStringField_GetWideText(Field, Result, False);
end;

procedure TntWideStringField_SetWideText(Field: TField;
  const Value: WideString);
{$IFDEF COMPILER_10_UP}
begin
  Field.AsWideString := Value;
end;
{$ELSE}
var
  WideStringField: IWideStringField;
begin
  Field.GetInterface(IWideStringField, WideStringField);
  Assert(WideStringField <> nil);
  WideStringField.SetAsWideString(Value);
end;
{$ENDIF}

procedure TntWideStringField_SetWideEditText(Field: TField;
  OnSetText: TFieldSetWideTextEvent; const Value: WideString);
begin
  if Assigned(OnSetText) then
    OnSetText(Field, Value)
  else if Assigned(Field.OnSetText) then
    Field.Text := Value {we lose Unicode to handle this event}
  else
    TntWideStringField_SetWideText(Field, Value);
end;

{ TTntWideStringField }

{$IFNDEF COMPILER_10_UP}
function TTntWideStringField.GetAsWideString: WideString;
begin
  if not GetData(@Result, False) then
    Result := ''; {fixes a bug in inherited which has unpredictable results for NULL}
end;
{$ENDIF}

procedure TTntWideStringField.LegacyGetText(Sender: TField; var AnsiText: AnsiString;
  DoDisplayText: Boolean);
begin
  TntWideStringField_LegacyGetText(Sender, OnGetText, AnsiText, DoDisplayText);
end;

procedure TTntWideStringField.LegacySetText(Sender: TField; const AnsiText: AnsiString);
begin
  TntWideStringField_LegacySetText(Sender, OnSetText, AnsiText);
end;

procedure TTntWideStringField.SetOnGetText(const Value: TFieldGetWideTextEvent);
begin
  FOnGetText := Value;
  if Assigned(OnGetText) then
    inherited OnGetText := LegacyGetText
  else
    inherited OnGetText := nil;
end;

procedure TTntWideStringField.SetOnSetText(const Value: TFieldSetWideTextEvent);
begin
  FOnSetText := Value;
  if Assigned(OnSetText) then
    inherited OnSetText := LegacySetText
  else
    inherited OnSetText := nil;
end;

function TTntWideStringField.GetWideDisplayText: WideString;
begin
  Result := TntWideStringField_GetWideDisplayText(Self, OnGetText);
end;

function TTntWideStringField.GetWideEditText: WideString;
begin
  Result := TntWideStringField_GetWideEditText(Self, OnGetText);
end;

procedure TTntWideStringField.SetWideEditText(const Value: WideString);
begin
  TntWideStringField_SetWideEditText(Self, OnSetText, Value);
end;

(* This stuffing method works with CJK codepages - intended to store accented characters in Access 97 *)

function SafeStringToWideStringEx(const S: AnsiString; Codepage: Word): WideString;
var
  R: AnsiString;
  i: Integer;
begin
  R := '';
  i := 1;
  while i <= Length(S) do
  begin
    if (S[i] = #128) then
    begin
      Inc(i);
      if S[i] = #128 then
        R := R + #128
      else
        R := R + Chr(Ord(S[i]) + 128);
      Inc(i);
    end
    else
    begin
      R := R + S[I];
      Inc(i);
    end;
  end;
  Result := StringToWideStringEx(R, CodePage);
end;

function SafeWideStringToStringEx(const W: WideString; CodePage: Word): AnsiString;
var
  TempS: AnsiString;
  i: integer;
begin
  TempS := WideStringToStringEx(W, CodePage);
  Result := '';
  for i := 1 to Length(TempS) do
  begin
    if TempS[i] > #128 then
      Result := Result + #128 + Chr(Ord(TempS[i]) - 128)
    else if TempS[i] = #128 then
      Result := Result + #128 + #128
    else
      Result := Result + TempS[i];
  end;
end;

{ TTntStringField }

constructor TTntStringField.Create(AOwner: TComponent);
begin
  inherited;
  FEncodingMode := emUTF8;
  FFixedCodePage := TntStringFieldCodePageEnumMap[fcpLatinWestern]
end;

function TTntStringField.GetFixedCodePageEnum: TTntStringFieldCodePageEnum;
var
  i: TTntStringFieldCodePageEnum;
begin
  Result := fcpOther;
  for i := Low(TntStringFieldCodePageEnumMap) to High(TntStringFieldCodePageEnumMap) do begin
    if TntStringFieldCodePageEnumMap[i] = FixedCodePage then begin
      Result := i;
      Break; {found it}
    end;
  end;
end;

procedure TTntStringField.SetFixedCodePageEnum(const Value: TTntStringFieldCodePageEnum);
begin
  if (Value <> fcpOther) then
    FixedCodePage := TntStringFieldCodePageEnumMap[Value];
end;

function TTntStringField.GetAsVariant: Variant;
begin
  if RawVariantAccess then
    Result := inherited GetAsVariant
  else if IsNull then
    Result := Null
  else
    Result := GetAsWideString;
end;

procedure TTntStringField.SetVarValue(const Value: Variant);
begin
  if RawVariantAccess then
    inherited
  else
    SetAsWideString(Value);
end;

function TTntStringField.GetAsWideString: WideString;
begin
  case EncodingMode of
    emNone:               Result := (inherited GetAsString);
    emUTF8:               Result := UTF8ToWideString(inherited GetAsString);
    emUTF7:             try
                          Result := UTF7ToWideString(inherited GetAsString);
                        except
                          Result := inherited GetAsString;
                        end;
    emFixedCodePage:      Result := StringToWideStringEx(inherited GetAsString, FixedCodePage);
    emFixedCodePage_Safe: Result := SafeStringToWideStringEx(inherited GetAsString, FixedCodePage);
    else
      raise ETntInternalError.Create('Internal Error: Unexpected EncodingMode');
  end;
end;

procedure TTntStringField.SetAsWideString(const Value: WideString);
begin
  case EncodingMode of
    emNone:               inherited SetAsString(Value);
    emUTF8:               inherited SetAsString(WideStringToUTF8(Value));
    emUTF7:               inherited SetAsString(WideStringToUTF7(Value));
    emFixedCodePage:      inherited SetAsString(WideStringToStringEx(Value, FixedCodePage));
    emFixedCodePage_Safe: inherited SetAsString(SafeWideStringToStringEx(Value, FixedCodePage));
    else
      raise ETntInternalError.Create('Internal Error: Unexpected EncodingMode');
  end;
end;

function TTntStringField.GetAsString: string{TNT-ALLOW string};
begin
  if EncodingMode = emNone then
    Result := inherited GetAsString
  else
    Result := GetAsWideString;
end;

procedure TTntStringField.SetAsString(const Value: string{TNT-ALLOW string});
begin
  if EncodingMode = emNone then
    inherited SetAsString(Value)
  else
    SetAsWideString(Value);
end;

procedure TTntStringField.LegacyGetText(Sender: TField; var AnsiText: AnsiString;
  DoDisplayText: Boolean);
begin
  TntWideStringField_LegacyGetText(Sender, OnGetText, AnsiText, DoDisplayText);
end;

procedure TTntStringField.LegacySetText(Sender: TField; const AnsiText: AnsiString);
begin
  TntWideStringField_LegacySetText(Sender, OnSetText, AnsiText);
end;

procedure TTntStringField.SetOnGetText(const Value: TFieldGetWideTextEvent);
begin
  FOnGetText := Value;
  if Assigned(OnGetText) then
    inherited OnGetText := LegacyGetText
  else
    inherited OnGetText := nil;
end;

procedure TTntStringField.SetOnSetText(const Value: TFieldSetWideTextEvent);
begin
  FOnSetText := Value;
  if Assigned(OnSetText) then
    inherited OnSetText := LegacySetText
  else
    inherited OnSetText := nil;
end;

function TTntStringField.GetWideDisplayText: WideString;
begin
  Result := TntWideStringField_GetWideDisplayText(Self, OnGetText)
end;

function TTntStringField.GetWideEditText: WideString;
begin
  Result := TntWideStringField_GetWideEditText(Self, OnGetText);
end;

procedure TTntStringField.SetWideEditText(const Value: WideString);
begin
  TntWideStringField_SetWideEditText(Self, OnSetText, Value);
end;

function TTntStringField.IsFixedCodePageStored: Boolean;
begin
  Result := EncodingMode = emFixedCodePage;
end;

//---------------------------------------------------------------------------------------------
procedure RegisterTntFields;
begin
  RegisterFields([TTntDateTimeField]);
  RegisterFields([TTntDateField]);
  RegisterFields([TTntTimeField]);
  RegisterFields([TTntWideStringField]);
  RegisterFields([TTntStringField]);
end;

type PFieldClass = ^TFieldClass;

initialization
{$IFDEF TNT_FIELDS}
  PFieldClass(@DefaultFieldClasses[ftDate])^ := TTntDateField;
  PFieldClass(@DefaultFieldClasses[ftTime])^ := TTntTimeField;
  PFieldClass(@DefaultFieldClasses[ftDateTime])^ := TTntDateTimeField;
  PFieldClass(@DefaultFieldClasses[ftWideString])^ := TTntWideStringField;
  PFieldClass(@DefaultFieldClasses[ftString])^ := TTntStringField;
  PFieldClass(@DefaultFieldClasses[ftFixedChar])^ := TTntStringField;
{$ENDIF}

{$IFNDEF COMPILER_10_UP}
  WideFieldHelpers := TComponentList.Create(True);
{$ENDIF}

finalization
{$IFNDEF COMPILER_10_UP}
  FreeAndNil(WideFieldHelpers);
{$ENDIF}


end.