tntclasses.pas

TNT Components Source

procedure TTntStringList.SetUpdateState(Updating: Boolean);
begin
  FUpdating := Updating;
  if Updating then Changing else Changed;
end;

function WideStringListCompareStrings(List: TTntStringList; Index1, Index2: Integer): Integer;
begin
  Result := List.CompareStrings(List.FList^[Index1].FString,
                                List.FList^[Index2].FString);
end;

procedure TTntStringList.Sort;
begin
  CustomSort(WideStringListCompareStrings);
end;

procedure TTntStringList.CustomSort(Compare: TWideStringListSortCompare);
begin
  if not Sorted and (FCount > 1) then
  begin
    Changing;
    QuickSort(0, FCount - 1, Compare);
    Changed;
  end;
end;

function TTntStringList.CompareStrings(const S1, S2: WideString): Integer;
begin
  if CaseSensitive then
    Result := WideCompareStr(S1, S2)
  else
    Result := WideCompareText(S1, S2);
end;

procedure TTntStringList.SetCaseSensitive(const Value: Boolean);
begin
  if Value <> FCaseSensitive then
  begin
    FCaseSensitive := Value;
    if Sorted then Sort;
  end;
end;

//------------------------- TntClasses introduced procs ----------------------------------

function AutoDetectCharacterSet(Stream: TStream): TTntStreamCharSet;
var
  ByteOrderMark: WideChar;
  BytesRead: Integer;
  Utf8Test: array[0..2] of AnsiChar;
begin
  // Byte Order Mark
  ByteOrderMark := #0;
  if (Stream.Size - Stream.Position) >= SizeOf(ByteOrderMark) then begin
    BytesRead := Stream.Read(ByteOrderMark, SizeOf(ByteOrderMark));
    if (ByteOrderMark <> UNICODE_BOM) and (ByteOrderMark <> UNICODE_BOM_SWAPPED) then begin
      ByteOrderMark := #0;
      Stream.Seek(-BytesRead, soFromCurrent);
      if (Stream.Size - Stream.Position) >= Length(Utf8Test) * SizeOf(AnsiChar) then begin
        BytesRead := Stream.Read(Utf8Test[0], Length(Utf8Test) * SizeOf(AnsiChar));
        if Utf8Test <> UTF8_BOM then
          Stream.Seek(-BytesRead, soFromCurrent);
      end;
    end;
  end;
  // Test Byte Order Mark
  if ByteOrderMark = UNICODE_BOM then
    Result := csUnicode
  else if ByteOrderMark = UNICODE_BOM_SWAPPED then
    Result := csUnicodeSwapped
  else if Utf8Test = UTF8_BOM then
    Result := csUtf8
  else
    Result := csAnsi;
end;

function FindSortedListByTarget(List: TList; TargetCompare: TListTargetCompare;
  Target: Pointer; var Index: Integer): Boolean;
var
  L, H, I, C: Integer;
begin
  Result := False;
  L := 0;
  H := List.Count - 1;
  while L <= H do
  begin
    I := (L + H) shr 1;
    C := TargetCompare(List[i], Target);
    if C < 0 then L := I + 1 else
    begin
      H := I - 1;
      if C = 0 then
      begin
        Result := True;
        L := I;
      end;
    end;
  end;
  Index := L;
end;

function ClassIsRegistered(const clsid: TCLSID): Boolean;
var
  OleStr: POleStr;
  Reg: TRegIniFile;
  Key, Filename: WideString;
begin
  // First, check to see if there is a ProgID.  This will tell if the
  // control is registered on the machine.  No ProgID, control won't run
  Result := ProgIDFromCLSID(clsid, OleStr) = S_OK;
  if not Result then Exit;  //Bail as soon as anything goes wrong.

  // Next, make sure that the file is actually there by rooting it out
  // of the registry
  Key := WideFormat('\SOFTWARE\Classes\CLSID\%s', [GUIDToString(clsid)]);
  Reg := TRegIniFile.Create;
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    Result := Reg.OpenKeyReadOnly(Key);
    if not Result then Exit; // Bail as soon as anything goes wrong.

    FileName := Reg.ReadString('InProcServer32', '', EmptyStr);
    if (Filename = EmptyStr) then // try another key for the file name
    begin
      FileName := Reg.ReadString('InProcServer', '', EmptyStr);
    end;
    Result := Filename <> EmptyStr;
    if not Result then Exit;
    Result := WideFileExists(Filename);
  finally
    Reg.Free;
  end;
end;

{ TBufferedAnsiString }

procedure TBufferedAnsiString.Clear;
begin
  LastWriteIndex := 0;
  if Length(FStringBuffer) > 0 then
    FillChar(FStringBuffer[1], Length(FStringBuffer) * SizeOf(AnsiChar), 0);
end;

procedure TBufferedAnsiString.AddChar(const wc: AnsiChar);
const
  MIN_GROW_SIZE = 32;
  MAX_GROW_SIZE = 256;
var
  GrowSize: Integer;
begin
  Inc(LastWriteIndex);
  if LastWriteIndex > Length(FStringBuffer) then begin
    GrowSize := Max(MIN_GROW_SIZE, Length(FStringBuffer));
    GrowSize := Min(GrowSize, MAX_GROW_SIZE);
    SetLength(FStringBuffer, Length(FStringBuffer) + GrowSize);
    FillChar(FStringBuffer[LastWriteIndex], GrowSize * SizeOf(AnsiChar), 0);
  end;
  FStringBuffer[LastWriteIndex] := wc;
end;

procedure TBufferedAnsiString.AddString(const s: AnsiString);
var
  LenS: Integer;
  BlockSize: Integer;
  AllocSize: Integer;
begin
  LenS := Length(s);
  if LenS > 0 then begin
    Inc(LastWriteIndex);
    if LastWriteIndex + LenS - 1 > Length(FStringBuffer) then begin
      // determine optimum new allocation size
      BlockSize := Length(FStringBuffer) div 2;
      if BlockSize < 8 then
        BlockSize := 8;
      AllocSize := ((LenS div BlockSize) + 1) * BlockSize;
      // realloc buffer
      SetLength(FStringBuffer, Length(FStringBuffer) + AllocSize);
      FillChar(FStringBuffer[Length(FStringBuffer) - AllocSize + 1], AllocSize * SizeOf(AnsiChar), 0);
    end;
    CopyMemory(@FStringBuffer[LastWriteIndex], @s[1], LenS * SizeOf(AnsiChar));
    Inc(LastWriteIndex, LenS - 1);
  end;
end;

procedure TBufferedAnsiString.AddBuffer(Buff: PAnsiChar; Chars: Integer);
var
  i: integer;
begin
  for i := 1 to Chars do begin
    if Buff^ = #0 then
      break;
    AddChar(Buff^);
    Inc(Buff);
  end;
end;

function TBufferedAnsiString.Value: AnsiString;
begin
  Result := PAnsiChar(FStringBuffer);
end;

function TBufferedAnsiString.BuffPtr: PAnsiChar;
begin
  Result := PAnsiChar(FStringBuffer);
end;

{ TBufferedWideString }

procedure TBufferedWideString.Clear;
begin
  LastWriteIndex := 0;
  if Length(FStringBuffer) > 0 then
    FillChar(FStringBuffer[1], Length(FStringBuffer) * SizeOf(WideChar), 0);
end;

procedure TBufferedWideString.AddChar(const wc: WideChar);
const
  MIN_GROW_SIZE = 32;
  MAX_GROW_SIZE = 256;
var
  GrowSize: Integer;
begin
  Inc(LastWriteIndex);
  if LastWriteIndex > Length(FStringBuffer) then begin
    GrowSize := Max(MIN_GROW_SIZE, Length(FStringBuffer));
    GrowSize := Min(GrowSize, MAX_GROW_SIZE);
    SetLength(FStringBuffer, Length(FStringBuffer) + GrowSize);
    FillChar(FStringBuffer[LastWriteIndex], GrowSize * SizeOf(WideChar), 0);
  end;
  FStringBuffer[LastWriteIndex] := wc;
end;

procedure TBufferedWideString.AddString(const s: WideString);
var
  i: integer;
begin
  for i := 1 to Length(s) do
    AddChar(s[i]);
end;

procedure TBufferedWideString.AddBuffer(Buff: PWideChar; Chars: Integer);
var
  i: integer;
begin
  for i := 1 to Chars do begin
    if Buff^ = #0 then
      break;
    AddChar(Buff^);
    Inc(Buff);
  end;
end;

function TBufferedWideString.Value: WideString;
begin
  Result := PWideChar(FStringBuffer);
end;

function TBufferedWideString.BuffPtr: PWideChar;
begin
  Result := PWideChar(FStringBuffer);
end;

{ TBufferedStreamReader }

constructor TBufferedStreamReader.Create(Stream: TStream; BufferSize: Integer = 1024);
begin
  // init stream
  FStream := Stream;
  FStreamSize := Stream.Size;
  // init buffer
  FBufferSize := BufferSize;
  SetLength(FBuffer, BufferSize);
  FBufferStartPosition := -FBufferSize; { out of any useful range }
  // init virtual position
  FVirtualPosition := 0;
end;

function TBufferedStreamReader.Seek(Offset: Integer; Origin: Word): Longint;
begin
  case Origin of
    soFromBeginning: FVirtualPosition := Offset;
    soFromCurrent:   Inc(FVirtualPosition, Offset);
    soFromEnd:       FVirtualPosition := FStreamSize + Offset;
  end;
  Result := FVirtualPosition;
end;

procedure TBufferedStreamReader.UpdateBufferFromPosition(StartPos: Integer);
begin
  try
    FStream.Position := StartPos;
    FStream.Read(FBuffer[0], FBufferSize);
    FBufferStartPosition := StartPos;
  except
    FBufferStartPosition := -FBufferSize; { out of any useful range }
    raise;
  end;
end;

function TBufferedStreamReader.Read(var Buffer; Count: Integer): Longint;
var
  BytesLeft: Integer;
  FirstBufferRead: Integer;
  StreamDirectRead: Integer;
  Buf: PAnsiChar;
begin
  if (FVirtualPosition >= 0) and (Count >= 0) then
  begin
    Result := FStreamSize - FVirtualPosition;
    if Result > 0 then
    begin
      if Result > Count then
        Result := Count;

      Buf := @Buffer;
      BytesLeft := Result;

      // try to read what is left in buffer
      FirstBufferRead := FBufferStartPosition + FBufferSize - FVirtualPosition;
      if (FirstBufferRead < 0) or (FirstBufferRead > FBufferSize) then
        FirstBufferRead := 0;
      FirstBufferRead := Min(FirstBufferRead, Result);
      if FirstBufferRead > 0 then begin
        Move(FBuffer[FVirtualPosition - FBufferStartPosition], Buf[0], FirstBufferRead);
        Dec(BytesLeft, FirstBufferRead);
      end;

      if BytesLeft > 0 then begin
        // The first read in buffer was not enough
        StreamDirectRead := (BytesLeft div FBufferSize) * FBufferSize;
        FStream.Position := FVirtualPosition + FirstBufferRead;
        FStream.Read(Buf[FirstBufferRead], StreamDirectRead);
        Dec(BytesLeft, StreamDirectRead);

        if BytesLeft > 0 then begin
          // update buffer, and read what is left
          UpdateBufferFromPosition(FStream.Position);
          Move(FBuffer[0], Buf[FirstBufferRead + StreamDirectRead], BytesLeft);
        end;
      end;

      Inc(FVirtualPosition, Result);
      Exit;
    end;
  end;
  Result := 0;
end;

function TBufferedStreamReader.Write(const Buffer; Count: Integer): Longint;
begin
  raise ETntInternalError.Create('Internal Error: class can not write.');
  Result := 0;
end;

//-------- synced wide string -----------------

function GetSyncedWideString(var WideStr: WideString; const AnsiStr: AnsiString): WideString;
begin
  if AnsiString(WideStr) <> (AnsiStr) then begin
    WideStr := AnsiStr; {AnsiStr changed.  Keep WideStr in sync.}
  end;
  Result := WideStr;
end;

procedure SetSyncedWideString(const Value: WideString; var WideStr: WideString;
  const AnsiStr: AnsiString; SetAnsiStr: TSetAnsiStrEvent);
begin
  if Value <> GetSyncedWideString(WideStr, AnsiStr) then
  begin
    if (not WideSameStr(Value, AnsiString(Value))) {unicode chars lost in conversion}
    and (AnsiStr = AnsiString(Value))  {AnsiStr is not going to change}
    then begin
      SetAnsiStr(''); {force the change}
    end;
    WideStr := Value;
    SetAnsiStr(Value);
  end;
end;

{ TWideComponentHelper }

function CompareComponentHelperToTarget(Item, Target: Pointer): Integer;
begin
  if Integer(TWideComponentHelper(Item).FComponent) < Integer(Target) then
    Result := -1
  else if Integer(TWideComponentHelper(Item).FComponent) > Integer(Target) then
    Result := 1
  else
    Result := 0;
end;

function FindWideComponentHelperIndex(ComponentHelperList: TComponentList; Component: TComponent; var Index: Integer): Boolean;
begin
  // find Component in sorted wide caption list (list is sorted by TWideComponentHelper.FComponent)
  Result := FindSortedListByTarget(ComponentHelperList, CompareComponentHelperToTarget, Component, Index);
end;

constructor TWideComponentHelper.Create(AOwner: TComponent);
begin
  raise ETntInternalError.Create('TNT Internal Error: TWideComponentHelper.Create should never be encountered.');
end;

constructor TWideComponentHelper.CreateHelper(AOwner: TComponent; ComponentHelperList: TComponentList);
var
  Index: Integer;
begin
  // don't use direct ownership for memory management
  inherited Create(nil);
  FComponent := AOwner;
  FComponent.FreeNotification(Self);

  // insert into list according to sort
  FindWideComponentHelperIndex(ComponentHelperList, FComponent, Index);
  ComponentHelperList.Insert(Index, Self);
end;

procedure TWideComponentHelper.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited;
  if (AComponent = FComponent) and (Operation = opRemove) then begin
    FComponent := nil;
    Free;
  end;
end;

function FindWideComponentHelper(ComponentHelperList: TComponentList; Component: TComponent): TWideComponentHelper;
var
  Index: integer;
begin
  if FindWideComponentHelperIndex(ComponentHelperList, Component, Index) then begin
  	Result := TWideComponentHelper(ComponentHelperList[Index]);
    Assert(Result.FComponent = Component, 'TNT Internal Error: FindWideComponentHelperIndex failed.');
  end else
    Result := nil;
end;

initialization
  RuntimeUTFStreaming := False; { Delphi 6 and higher don't need UTF help at runtime. }

end.