clutils.pas

Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码

    begin
      if (APath[i] = '\') then
      begin
        if (s <> '') then
        begin
          AList.Add(s);
        end;
        s := '';
      end else
      begin
        s := APath[i] + s;
      end;
    end;
    if (s <> '') then
    begin
      AList.Add(s);
    end;
  end;

  function MatchPathLists(ABaseList, ARelList: TStrings): string;
  var
    i, j: Integer;
  begin
    Result := '';
    
    i := ABaseList.Count - 1;
    j := ARelList.Count - 1;
    while (i >= 0) and (j >= 0) and (ABaseList[i] = ARelList[j]) do
    begin
      Dec(i);
      Dec(j);
    end;

    while (i >= 0) do
    begin
      Result := Result + '..\';
      Dec(i);
    end;

    while (j >= 1) do
    begin
      Result := Result + ARelList[j] + '\';
      Dec(j);
    end;

    Result := Result + ARelList[j];
  end;

var
  baseList, relList: TStrings;
begin
  Result := '';
  baseList := nil;
  relList := nil;
  try
    baseList := TStringList.Create();
    relList := TStringList.Create();
    
    GetPathList(ExtractFilePath(ABasePath), baseList);
    GetPathList(ARelativePath, relList);

    Result := MatchPathLists(baseList, relList);
  finally
    relList.Free();
    baseList.Free();
  end;
end;

function GetUniqueFileName(const AFileName: string): string;
var
  s: string;
  i, ind: Integer;
begin
  i := 1;
  Result := AFileName;
  s := Result;
  ind := RTextPos('.', s);
  if (ind < 1) then
  begin
    s := s + '.';
    ind := Length(s);
  end;
  while FileExists(Result) do
  begin
    Result := system.Copy(s, 1, ind - 1) + Format('%d', [i]) + system.Copy(s, ind, Length(s));
    Inc(i);
  end;
  if (Length(Result) > 0) and (Result[Length(Result)] = '.') then
  begin
    system.Delete(Result, Length(Result), 1);
  end;
end;

function AddTrailingBackSlash(const APath: string): string;
begin
  Result := APath; 
  if (Result <> '') and (Result[Length(Result)] <> '\') then
  begin
    Result := Result + '\';
  end;
end;

function NormalizeWin32Path(const APath: string; const AReplaceWith: string): string;
const
  invalidChars: set of Char = ['"', '*', '/', ':', '<', '>', '?', '\', '|', #0];
  invalidLastChars: set of Char = [' ', '.'];
var
  i: Integer;
begin
  Result := '';
  for i := 1 to Length(APath) do
  begin
    if (APath[i] in invalidChars) then
    begin
      Result := Result + AReplaceWith;
    end else
    begin
      Result := Result + APath[i];
    end;
  end;

  if (Length(Result) > 0) and (Result[Length(Result)] in invalidLastChars) then
  begin
    Delete(Result, Length(Result), 1);
    if (Result = '') then
    begin
      Result := '_';
    end;
  end;
end;

{$IFNDEF DELPHI6}
function DirectoryExists(const Directory: string): Boolean;
var
  Code: Integer;
begin
  Code := GetFileAttributes(PChar(Directory));
  Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
end;
{$ENDIF}

procedure ByteArrayWriteWord(AData: Word; var ADestination: TclByteArray; var AIndex: Integer);
begin
  ADestination[AIndex] := AData div 256;
  Inc(AIndex);
  ADestination[AIndex] := AData mod 256;
  Inc(AIndex);
end;

function ByteArrayReadWord(const ASource: TclByteArray; var AIndex: Integer): Word;
begin
  Result := ASource[AIndex] shl 8;
  Inc(AIndex);
  Result := Result or ASource[AIndex];
  Inc(AIndex);
end;

function ByteArrayReadDWord(const ASource: TclByteArray; var AIndex: Integer): DWORD;
begin
  Result := ByteArrayReadWord(ASource, AIndex) shl 16;
  Result := Result or ByteArrayReadWord(ASource, AIndex);
end;

function MakeWord(AByte1, AByte2: Byte): Word;
var
  arr: array[0..1] of Byte;
begin
  arr[1] := AByte1;
  arr[0] := AByte2;
  Result := PWORD(@arr[0])^;
end;

function GetBinTextPos(const ASubStr: string; AData: PChar; ADataPos, ADataSize: Integer): Integer;
var
  i, curPos, endPos: Integer;
begin
  curPos := 1;
  endPos := Length(ASubStr) + 1;

  for i := ADataPos to ADataSize - 1 do
  begin
    if (PChar(Integer(AData) + i)^ = ASubStr[curPos]) then
    begin
      Inc(curPos);
    end else
    begin
      curPos := 1;
      Continue;
    end;
    if (Curpos = endPos) then
    begin
      Result := i - endPos + 2;
      Exit;
    end;
  end;
  Result := -1;
end;

function GetStringsSize(ALines: TStrings): Integer;
const
  cCRLF = #13#10;
var
  i: Integer;
begin
  Result := 0;
  for i := 0 to ALines.Count - 1 do
  begin
    Result := Result + Length(ALines[i]) + Length(cCRLF);
  end;
end;

function FindInStrings(AList: TStrings; const Value: string): Integer;
var
  i: Integer;
begin
  for i := 0 to AList.Count - 1 do
  begin
    if SameText(Value, AList[i]) then
    begin
      Result := i;
      Exit;
    end;
  end;
  Result := -1;
end;

function GetCurrentThreadUser: string;
var
  p: PChar;
  size: DWORD;
begin
  Result := '';
  size := 0;
  GetUserName(nil, size);

  if (size < 1) then Exit;

  GetMem(p, size + 1);
  try
    if GetUserName(p, size) then
    begin
      Result := string(p);
    end;
  finally
    FreeMem(p);
  end;
end;

{ TclWideStringList }

function TclWideStringList.Add(const S: WideString): Integer;
begin
  Result := AddObject(S, nil);
end;

function TclWideStringList.AddObject(const S: WideString; AObject: TObject): Integer;
begin
  if not Sorted then
  begin
    Result := FCount
  end else
  if Find(S, Result) then
  begin
    case Duplicates of
      dupIgnore: Exit;
      dupError: Error(SDuplicateString, 0);
    end;
  end;
  InsertItem(Result, S, AObject);
end;

procedure TclWideStringList.Clear;
begin
  if FCount <> 0 then
  begin
    Finalize(FList^[0], FCount);
    FCount := 0;
    SetCapacity(0);
  end;
end;

function TclWideStringList.CompareStrings(const S1, S2: WideString): Integer;
begin
  if (S1 > S2) then
  begin
    Result := 1;
  end else
  if (S1 < S2) then
  begin
    Result := -1;
  end else
  begin
    Result := 0;
  end;
end;

procedure TclWideStringList.Delete(Index: Integer);
begin
  if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  Finalize(FList^[Index]);
  Dec(FCount);
  if Index < FCount then
  begin
    System.Move(FList^[Index + 1], FList^[Index],
      (FCount - Index) * SizeOf(TWideStringItem));
  end;
end;

destructor TclWideStringList.Destroy;
begin
  inherited Destroy();
  if FCount <> 0 then Finalize(FList^[0], FCount);
  FCount := 0;
  SetCapacity(0);
end;

procedure TclWideStringList.Error(const Msg: string; Data: Integer);
  function ReturnAddr: Pointer;
  asm
          MOV     EAX,[EBP+4]
  end;
begin
  raise EStringListError.CreateFmt(Msg, [Data]) at ReturnAddr;
end;

procedure TclWideStringList.ExchangeItems(Index1, Index2: Integer);
var
  Temp: Integer;
  Item1, Item2: PWideStringItem;
begin
  Item1 := @FList^[Index1];
  Item2 := @FList^[Index2];
  Temp := Integer(Item1^.FString);
  Integer(Item1^.FString) := Integer(Item2^.FString);
  Integer(Item2^.FString) := Temp;
  Temp := Integer(Item1^.FObject);
  Integer(Item1^.FObject) := Integer(Item2^.FObject);
  Integer(Item2^.FObject) := Temp;
end;

function TclWideStringList.Find(const S: WideString; var Index: Integer): Boolean;
var
  L, H, I, C: Integer;
begin
  Result := False;
  L := 0;
  H := FCount - 1;
  while L <= H do
  begin
    I := (L + H) shr 1;
    C := CompareStrings(FList^[I].FString, S);
    if C < 0 then L := I + 1 else
    begin
      H := I - 1;
      if C = 0 then
      begin
        Result := True;
        if Duplicates <> dupAccept then L := I;
      end;
    end;
  end;
  Index := L;
end;

function TclWideStringList.Get(Index: Integer): WideString;
begin
  if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  Result := FList^[Index].FString;
end;

function TclWideStringList.GetObject(Index: Integer): TObject;
begin
  if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  Result := FList^[Index].FObject;
end;

procedure TclWideStringList.Grow;
var
  Delta: Integer;
begin
  if FCapacity > 256 then
  begin
    Delta := FCapacity div 4;
  end else
  begin
    Delta := 64;
  end;
  SetCapacity(FCapacity + Delta);
end;

function TclWideStringList.IndexOf(const S: WideString): Integer;
begin
  if not Sorted then
  begin
    for Result := 0 to Count - 1 do
    begin
      if CompareStrings(Get(Result), S) = 0 then Exit;
    end;
    Result := -1;
  end else
  if not Find(S, Result) then
  begin
    Result := -1;
  end;
end;

function TclWideStringList.IndexOfObject(AObject: TObject): Integer;
begin
  for Result := 0 to Count - 1 do
  begin
    if GetObject(Result) = AObject then Exit;
  end;
  Result := -1;
end;

procedure TclWideStringList.Insert(Index: Integer; const S: WideString);
begin
  InsertObject(Index, S, nil);
end;

procedure TclWideStringList.InsertItem(Index: Integer; const S: WideString; AObject: TObject);
begin
  if FCount = FCapacity then Grow();
  
  if Index < FCount then
  begin
    System.Move(FList^[Index], FList^[Index + 1],
      (FCount - Index) * SizeOf(TWideStringItem));
  end;
  with FList^[Index] do
  begin
    Pointer(FString) := nil;
    FObject := AObject;
    FString := S;
  end;
  Inc(FCount);
end;

procedure TclWideStringList.InsertObject(Index: Integer;
  const S: WideString; AObject: TObject);
begin
  if Sorted then
  begin
    Error(SSortedListError, 0);
  end;
  if (Index < 0) or (Index > FCount) then
  begin
    Error(SListIndexError, Index);
  end;
  InsertItem(Index, S, AObject);
end;

procedure TclWideStringList.Move(CurIndex, NewIndex: Integer);
var
  TempObject: TObject;
  TempString: WideString;
begin
  if CurIndex <> NewIndex then
  begin
    TempString := Get(CurIndex);
    TempObject := GetObject(CurIndex);
    Delete(CurIndex);
    InsertObject(NewIndex, TempString, TempObject);
  end;
end;

procedure TclWideStringList.Put(Index: Integer; const S: WideString);
begin
  if Sorted then Error(SSortedListError, 0);
  if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  FList^[Index].FString := S;
end;

procedure TclWideStringList.PutObject(Index: Integer; AObject: TObject);
begin
  if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  FList^[Index].FObject := AObject;
end;

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

procedure TclWideStringList.QuickSort(L, R: Integer);
var
  I, J, P: Integer;
begin
  repeat
    I := L;
    J := R;
    P := (L + R) shr 1;
    repeat
      while WideCompare(Self, I, P) < 0 do Inc(I);
      while WideCompare(Self, J, P) > 0 do Dec(J);
      if I <= J then
      begin
        ExchangeItems(I, J);
        if P = I then
          P := J
        else if P = J then
          P := I;
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then QuickSort(L, J);
    L := I;
  until I >= R;
end;

procedure TclWideStringList.SetCapacity(NewCapacity: Integer);
begin
  ReallocMem(FList, NewCapacity * SizeOf(TWideStringItem));
  FCapacity := NewCapacity;
end;

procedure TclWideStringList.SetSorted(const Value: Boolean);
begin
  if FSorted <> Value then
  begin
    if Value then Sort();
    FSorted := Value;
  end;
end;

procedure TclWideStringList.Sort;
begin
  if not Sorted and (FCount > 1) then
  begin
    QuickSort(0, FCount - 1);
  end;
end;

end.