clutils.pas

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

{
  Clever Internet Suite Version 6.2
  Copyright (C) 1999 - 2006 Clever Components
  www.CleverComponents.com
}

unit clUtils;

interface

{$I clVer.inc}
{$IFDEF DELPHI6}
  {$WARNINGS OFF}
{$ENDIF}

uses
  Windows, Classes;

type
  TCharSet = Set of Char;

  TclByteArray = array of Byte;
  
  TclBinaryData = class
  private
    FData: PByte;
    FDataSize: Integer;
    procedure Deallocate;
  public
    destructor Destroy; override;
    procedure AssignByStrings(AStrings: TStrings);
    procedure Allocate(ASize: Integer);
    procedure Reduce(ANewSize: Integer);
    property Data: PByte read FData;
    property DataSize: Integer read FDataSize;
  end;

  PWideStringItem = ^TWideStringItem;
  TWideStringItem = record
    FString: WideString;
    FObject: TObject;
  end;

  PWideStringItemList = ^TWideStringItemList;
  TWideStringItemList = array[0..MaxListSize] of TWideStringItem;
  
  TclWideStringList = class
  private
    FList: PWideStringItemList;
    FCount: Integer;
    FCapacity: Integer;
    FSorted: Boolean;
    FDuplicates: TDuplicates;
    procedure SetSorted(const Value: Boolean);
    procedure QuickSort(L, R: Integer);
    procedure ExchangeItems(Index1, Index2: Integer);
    procedure Grow;
  protected
    procedure Error(const Msg: string; Data: Integer);
    function Get(Index: Integer): WideString; virtual;
    function GetObject(Index: Integer): TObject; virtual;
    procedure Put(Index: Integer; const S: WideString); virtual;
    procedure PutObject(Index: Integer; AObject: TObject); virtual;
    function CompareStrings(const S1, S2: WideString): Integer; virtual;
    procedure InsertItem(Index: Integer; const S: WideString; AObject: TObject); virtual;
    procedure SetCapacity(NewCapacity: Integer); virtual;
  public
    destructor Destroy; override;
    function Add(const S: WideString): Integer; virtual;
    function AddObject(const S: WideString; AObject: TObject): Integer; virtual;
    procedure Clear; virtual;
    procedure Delete(Index: Integer); virtual;
    function Find(const S: WideString; var Index: Integer): Boolean; virtual;
    function IndexOf(const S: WideString): Integer; virtual;
    function IndexOfObject(AObject: TObject): Integer; virtual;
    procedure Insert(Index: Integer; const S: WideString); virtual;
    procedure InsertObject(Index: Integer; const S: WideString;
      AObject: TObject); virtual;
    procedure Move(CurIndex, NewIndex: Integer); virtual;
    procedure Sort; virtual;
    property Count: Integer read FCount;
    property Objects[Index: Integer]: TObject read GetObject write PutObject;
    property Strings[Index: Integer]: WideString read Get write Put; default;
    property Duplicates: TDuplicates read FDuplicates write FDuplicates;
    property Sorted: Boolean read FSorted write SetSorted;
  end;

function AddTextStr(AList: TStrings; const Value: string; AddToLastString: Boolean = False): Boolean;
function AddTextStream(AList: TStrings; ASource: TStream;
  AddToLastString: Boolean = False; ABatchSize: Integer = 0): Boolean;
function GetTextStr(AList: TStrings; AStartFrom, ACount: Integer): string;
procedure GetTopLines(ASource: TStream; ATopLines: Integer; AMessage: TStrings);
function GetStreamAsString(AStream: TStream; ASize: Integer; DefaultChar: Char): string;
function GetDataAsText(Data: PChar; Size: Integer; DefaultChar: Char): string;
function GetBinTextPos(const ASubStr: string; AData: PChar; ADataPos, ADataSize: Integer): Integer;
procedure ByteArrayWriteWord(AData: Word; var ADestination: TclByteArray; var AIndex: Integer);
function ByteArrayReadWord(const ASource: TclByteArray; var AIndex: Integer): Word;
function ByteArrayReadDWord(const ASource: TclByteArray; var AIndex: Integer): DWORD;
function MakeWord(AByte1, AByte2: Byte): Word;
function GetStringsSize(ALines: TStrings): Integer;
function FindInStrings(AList: TStrings; const Value: string): Integer;

procedure SetLocalFileTime(const AFileName: string; ADate: TDateTime);
function GetFullFileName(const AFileName, AFolder: string): string;
function ForceFileDirectories(const AFilePath: string): Boolean;
function DeleteRecursiveDir(const ARoot: string): Boolean;
function MakeRelativePath(const ABasePath, ARelativePath: string): string;
function GetUniqueFileName(const AFileName: string): string;
function AddTrailingBackSlash(const APath: string): string;
function NormalizeWin32Path(const APath: string; const AReplaceWith: string = '_'): string;
{$IFNDEF DELPHI6}
function DirectoryExists(const Directory: string): Boolean;
{$ENDIF}

function WordCount(const S: string; const WordDelims: TCharSet): Integer;
function WordPosition(const N: Integer; const S: string; const WordDelims: TCharSet): Integer;
function ExtractWord(N: Integer; const S: string; const WordDelims: TCharSet): string;
function ExtractNumeric(const ASource: string; AStartPos: Integer): string;
function ExtractQuotedString(const S: string; const AQuoteBegin: Char; const AQuoteEnd: Char = #0): string;
function GetNormName(const AName: string): string;
function GetDenormName(const AName: string): string;
function TextPos(const SubStr, Str: string; StartPos: Integer = 1): Integer;
function RTextPos(const SubStr, Str: String; StartPos: Integer = -1): Integer;
function ReversedString(const AStr: string): string;
function IndexOfStrArray(const S: string; AStrArray: array of string): Integer;

function GetHeaderFieldList(AStartFrom: Integer; ASource, AFieldList: TStrings): Integer;
function GetHeaderFieldValue(ASource, AFieldList: TStrings; const AName: string): string; overload;
function GetHeaderFieldValue(ASource, AFieldList: TStrings; AIndex: Integer): string; overload;
function GetHeaderFieldValueItem(const ASource, AItemName: string): string;
procedure AddHeaderArrayField(ASource: TStrings; const AValues: array of string;
  const AName, ADelimiter: string);
procedure AddHeaderField(ASource: TStrings; const AName, AValue: string);
procedure RemoveHeaderField(ASource, AFieldList: TStrings; const AName: string); overload;
procedure RemoveHeaderField(ASource, AFieldList: TStrings; AIndex: Integer); overload;
procedure InsertHeaderFieldIfNeed(ASource: TStrings; const AName, AValue: string);

function GetCorrectY2k(const AYear : Integer): Integer;
function TimeZoneBiasString: string;
function TimeZoneBiasToDateTime(const ABias: string): TDateTime;
function GlobalTimeToLocalTime(ATime: TDateTime): TDateTime;
function LocalTimeToGlobalTime(ATime: TDateTime): TDateTime;
function ConvertFileTimeToDateTime(AFileTime: TFileTime): TDateTime;

function GetCurrentThreadUser: string;

const
  cBatchSize = 8192;
  cDays: array[1..7] of string = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
  cMonths: array[1..12] of string = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
    'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');

implementation

uses
  SysUtils, {$IFDEF DELPHI6}RTLConsts{$ELSE}Consts{$ENDIF};

{$IFNDEF DELPHI6}
function CurrentYear: Word;
var
  SystemTime: TSystemTime;
begin
  GetLocalTime(SystemTime);
  Result := SystemTime.wYear;
end;
{$ENDIF}
  
function TimeZoneBiasString: string;
var
  TimeZoneInfo: TTimeZoneInformation;
  TimeZoneID: DWORD;
  Bias: Integer;
  Sign: Char;
begin
  Bias := 0;
  TimeZoneID := GetTimeZoneInformation(TimeZoneInfo);
  if (TimeZoneID <> TIME_ZONE_ID_INVALID) then
  begin
    if (TimeZoneID = TIME_ZONE_ID_DAYLIGHT) then
      Bias := TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias else
      Bias := TimeZoneInfo.Bias;
  end;
  if (Bias > 0) then Sign := '-' else Sign := '+';
  Result := Format('%s%.2d%.2d', [Sign, Abs(Bias) div 60, Abs(Bias) mod 60]);
end;

function TimeZoneBiasToDateTime(const ABias: string): TDateTime;
var
  Sign: Char;
  Hour, Min: Word;
begin
  if (Length(ABias) > 4) and (ABias[1] in ['-', '+']) then
  begin
    Sign := ABias[1];
    Hour := StrToIntDef(Copy(ABias, 2, 2), 0);
    Min := StrToIntDef(Copy(ABias, 4, 2), 0);

{$IFDEF DELPHI6}
    if not TryEncodeTime(Hour, Min, 0, 0, Result) then
    begin
      Result := 0;
    end;
{$ELSE}
    try
      Result := EncodeTime(Hour, Min, 0, 0);
    except
      Result := 0;
    end;
{$ENDIF}

    if (Sign = '-') and (Result <> 0) then Result := - Result;
  end else
  begin
    Result := 0;
  end;
end;

function GlobalTimeToLocalTime(ATime: TDateTime): TDateTime;
var
  ST: TSystemTime;
  FT: TFileTime;
begin
  DateTimeToSystemTime(ATime, ST);
  SystemTimeToFileTime(ST, FT);
  FileTimeToLocalFileTime(FT, FT);
  FileTimeToSystemTime(FT, ST);
  Result := SystemTimeToDateTime(ST);
end;

function LocalTimeToGlobalTime(ATime: TDateTime): TDateTime;
var
  ST: TSystemTime;
  FT: TFileTime;
begin
  DateTimeToSystemTime(ATime, ST);
  SystemTimeToFileTime(ST, FT);
  LocalFileTimeToFileTime(FT, FT);
  FileTimeToSystemTime(FT, ST);
  Result := SystemTimeToDateTime(ST);
end;
          
function ConvertFileTimeToDateTime(AFileTime: TFileTime): TDateTime;
var
  lpSystemTime: TSystemTime;
  LocalFileTime: TFileTime;
begin
  if FileTimeToLocalFileTime(AFileTime, LocalFileTime) then
  begin
    FileTimeToSystemTime(LocalFileTime, lpSystemTime);
    Result := SystemTimeToDateTime(lpSystemTime);
  end else
  begin
    Result := 0;
  end;
end;

function GetCorrectY2k(const AYear : Integer): Integer;
begin
  Result := AYear;
  if (Result >= 100) then Exit;
  if TwoDigitYearCenturyWindow > 0 then
  begin
    if Result > TwoDigitYearCenturyWindow then
    begin
      Result := Result + (((CurrentYear() div 100) - 1) * 100);
    end else
    begin
      Result := Result + ((CurrentYear() div 100) * 100);
    end;
  end else
  begin
    Result := Result + ((CurrentYear() div 100) * 100);
  end;
end;

{ TclBinaryData }

procedure TclBinaryData.Allocate(ASize: Integer);
begin
  Deallocate();
  FDataSize := ASize;
  if (FDataSize > 0) then
  begin
    GetMem(FData, FDataSize);
  end;
end;

procedure TclBinaryData.AssignByStrings(AStrings: TStrings);
var
  I, L, Size: Integer;
  P: PChar;
  S, LB: string;
begin
  Size := 0;
  LB := #13#10;
  for I := 0 to AStrings.Count - 1 do
  begin
    Inc(Size, Length(AStrings[I]) + Length(LB));
  end;
  if (Size > 0) then
  begin
    Size := Size - Length(LB);
  end;
  Allocate(Size);
  P := Pointer(Data);
  for I := 0 to AStrings.Count - 1 do
  begin
    S := AStrings[I];
    L := Length(S);
    if L <> 0 then
    begin
      System.Move(Pointer(S)^, P^, L);
      Inc(P, L);
    end;
    L := Length(LB);
    if (L <> 0) and (I <> AStrings.Count - 1) then
    begin
      System.Move(Pointer(LB)^, P^, L);
      Inc(P, L);
    end;
  end;
end;

procedure TclBinaryData.Deallocate;
begin
  FreeMem(FData);
  FData := nil;
  FDataSize := 0;
end;

destructor TclBinaryData.Destroy;
begin
  Deallocate();
  inherited Destroy();
end;

procedure TclBinaryData.Reduce(ANewSize: Integer);
begin
  if (FDataSize > ANewSize) then
  begin
    FDataSize := ANewSize;
  end;
end;

function GetDelimitedValue(const ASource, AStartLexem: string): string;
var
  i, ind: Integer;
  inCommas: Boolean;
  commaChar: string;
begin
  if (AStartLexem = '') and (ASource <> '') then
  begin
    ind := 1;
  end else
  begin
    ind := system.Pos(AStartLexem, LowerCase(ASource));
  end;
  if (ind > 0) then
  begin
    Result := system.Copy(ASource, ind + Length(AStartLexem), 1000);
    inCommas := False;
    commaChar := '';
    for i := 1 to Length(Result) do
    begin
      if (commaChar = '') and (Result[i] in ['''', '"']) then
      begin
        commaChar := Result[i];
        inCommas := not inCommas;
      end else
      if (commaChar <> '') and (Result[i] = commaChar[1]) then
      begin
        inCommas := not inCommas;
      end;
      if (not inCommas) and (Result[i] in [';', ',']) then
      begin
        Result := system.Copy(Result, 1, i - 1);
        Break;
      end;
    end;
  end else
  begin
    Result := '';
  end;
end;

function GetHeaderFieldValueItem(const ASource, AItemName: string): string;
var
  s: string;
begin
  s := Trim(GetDelimitedValue(ASource, AItemName));
  if (s <> '') and (s[1] in ['''', '"']) and (s[Length(s)] in ['''', '"']) then
  begin
    Result := System.Copy(s, 2, Length(s) - 2);
  end else
  begin
    Result := s;
  end;
end;

function AddTextStr(AList: TStrings; const Value: string; AddToLastString: Boolean): Boolean;
var
  P, Start: PChar;
  S: string;
  b: Boolean;
begin
  b := AddToLastString;
  AList.BeginUpdate;
  try
    P := Pointer(Value);
    if P <> nil then
    begin
      while P^ <> #0 do
      begin
        Start := P;
        while not (P^ in [#0, #10, #13]) do Inc(P);
        SetString(S, Start, P - Start);
        if b and (AList.Count > 0) then
        begin
          AList[AList.Count - 1] := AList[AList.Count - 1] + S;
          b := False;
        end else
        begin
          AList.Add(S);
        end;
        if P^ = #13 then Inc(P);
        if P^ = #10 then Inc(P);
      end;
      Result := ((Length(Value) = 1) and (Value[1] <> #10))
        or ((Length(Value) > 1) and ((P - 2)^ <> #13) and ((P - 1)^ <> #10));
    end else
    begin
      Result := False;
    end;
  finally
    AList.EndUpdate;
  end;
end;

function AddTextStrCount(AList: TStrings; const Value: string;
  var AddToLastString: Boolean; var AHeadCount: Integer; ALinesCount: Integer): Boolean;
var
  P, Start: PChar;
  S: string;
  b: Boolean;
begin
  b := AddToLastString;
  P := Pointer(Value);

  AddToLastString := False;
  Result := False;

  if (P <> nil) then
  begin
    while (not Result) and (P^ <> #0) do
    begin
      Start := P;
      while not (P^ in [#0, #10, #13]) do Inc(P);
      SetString(S, Start, P - Start);
      if b and (AList.Count > 0) then
      begin
        AList[AList.Count - 1] := AList[AList.Count - 1] + S;
        b := False;
      end else
      begin
        AList.Add(S);
      end;
      if (Length(AList[AList.Count - 1]) = 0) and (AHeadCount = 0) then
      begin
        AHeadCount := AList.Count;
      end;
      Result := (AHeadCount > 0) and (AList.Count >= AHeadCount + ALinesCount);
      if P^ = #13 then Inc(P);
      if P^ = #10 then Inc(P);
    end;
    AddToLastString := (Length(Value) > 1) and ((P - 2)^ <> #13) and ((P - 1)^ <> #10);
  end;
end;

procedure GetTopLines(ASource: TStream; ATopLines: Integer; AMessage: TStrings);
var
  buf: string;
  bufSize, bytesRead, headCount: Integer;
  addToLastSring: Boolean;
begin
  AMessage.BeginUpdate();
  try
    AMessage.Clear();

    bufSize := ASource.Size - ASource.Position;
    if (bufSize > 76) then
    begin
      bufSize := 76;
    end;

    headCount := 0;
    addToLastSring := False;
    repeat
      SetString(buf, nil, bufSize);
      bytesRead := ASource.Read(Pointer(buf)^, bufSize);
      if bytesRead = 0 then Break;
      SetLength(buf, bytesRead);
    until AddTextStrCount(AMessage, buf, addToLastSring, headCount, ATopLines);
  finally
    AMessage.EndUpdate();
  end;
end;

function AddTextStream(AList: TStrings; ASource: TStream; AddToLastString: Boolean;
  ABatchSize: Integer): Boolean;
var
  size: Integer;
  p: PChar;
  i, cnt: Integer;
begin
  size := ASource.Size - ASource.Position;
  if (size > ABatchSize) and (ABatchSize > 0) then
  begin
    size := ABatchSize;
  end;
  GetMem(p, size + 1);
  try
    Result := AddToLastString;
    cnt := ASource.Read(p^, size);
    while (cnt > 0) do
    begin
      for i := 0 to cnt - 1 do
      begin
        if p[i] = #0 then
        begin
          p[i] := #32;
        end;
      end;
      p[cnt] := #0;
      Result := AddTextStr(AList, string(p), Result);
      cnt := ASource.Read(p^, size);
    end;
  finally