psiglobal.pas

一个delphi的p2p控件的源代码

  end;
  {We use ABS because EncodeTime will only accept positve values}
  Result := EncodeTime(Abs(iBias div 60), iBias mod 60, 0, 0);
  {The GetTimeZone function returns values oriented towards convertin
   a GMT time into a local time.  We wish to do the do the opposit by returning
   the difference between the local time and GMT.  So I just make a positive
   value negative and leave a negative value as positive}
  if iBias > 0 then
  begin
    Result := 0 - Result;
  end;
end;

function TimeZoneBias: Double;
var
  ATimeZone: TTimeZoneInformation;
begin
  if (GetTimeZoneInformation(ATimeZone) = TIME_ZONE_ID_DAYLIGHT) then begin
    result := ATimeZone.Bias + ATimeZone.DaylightBias;
  end else begin
    result := ATimeZone.Bias + ATimeZone.StandardBias;
  end;
  Result := Result / 1440;
end;

function GetTickCount: Cardinal;
begin
  Result := Windows.GetTickCount;
end;

procedure SetLocalTime(Value: TDateTime);
var
  SysTimeVar: TSystemTime;
begin
  DateTimeToSystemTime(Value, SysTimeVar);
  Windows.SetLocalTime(SysTimeVar);
end;

// PsiPorts returns a list of defined ports in /etc/services
function PsiPorts: TList;
var
  sLocation, s: String;
  idx, i, iPrev, iPosSlash: integer;
  sl: TStringList;
begin
  if FPsiPorts = nil then
  begin
    FPsiPorts := TList.Create;
    SetLength(sLocation, MAX_PATH);
    SetLength(sLocation, GetWindowsDirectory(pchar(sLocation), MAX_PATH));
    sLocation := IncludeTrailingBackslash(sLocation);
    if Win32Platform = VER_PLATFORM_WIN32_NT then begin
      sLocation := sLocation + 'system32\drivers\etc\';
    end;
    sl := TStringList.Create;
    try
      sl.LoadFromFile(sLocation + 'services');
      iPrev := 0;
      for idx := 0 to sl.Count - 1 do
      begin
        s := sl[idx];
        iPosSlash := AnsiPos('/', s);
        if (iPosSlash > 0) and
         not (AnsiPos('#', s) in [1..iPosSlash]) then
        begin // presumably found a port number that isn't commented
          i := iPosSlash;
          repeat
            dec(i);
            if i = 0 then begin
              raise EPsiException.CreateFmt(RSCorruptServicesFile, [sLocation + 'services']);
            end;
          until s[i] in WhiteSpace;
          i := StrToInt(Copy(s, i+1, iPosSlash-i-1));
          if i <> iPrev then begin
            FPsiPorts.Add(TObject(i));
          end;
          iPrev := i;
        end;
      end;
    finally
      sl.Free;
    end;
  end;
  Result := FPsiPorts;
end;

function Fetch(var AInput: string; const ADelim: string = ' '; const ADelete: Boolean = true)
 : string;
var
  iPos: Integer;
begin
  if ADelim = #0 then begin
    // AnsiPos does not work with #0
    iPos := Pos(ADelim, AInput);
  end else begin
    iPos := AnsiPos(ADelim, AInput);
  end;
  if iPos = 0 then begin
    Result := AInput;
    if ADelete then begin
      AInput := '';
    end;
  end else begin
    result := Copy(AInput, 1, iPos - 1);
    if ADelete then begin
      Delete(AInput, 1, iPos + Length(ADelim) - 1);
    end;
  end;
end;

{This searches an array of string for an occurance of SearchStr}
function PosInStrArray(SearchStr : string; Contents: array of string; const CaseSensitive: Boolean=True): Integer;
begin
  for Result := Low(Contents) to High(Contents) do begin
    if CaseSensitive then begin
      if SearchStr = Contents[Result] then begin
        Exit;
      end;
    end else begin
      if ANSISameText(SearchStr, Contents[Result]) then begin
        Exit;
      end;
    end;
  end;  //for Result := Low(Contents) to High(Contents) do
  Result := -1;
end;

function IsCurrentThread(AThread: TThread): boolean;
begin
  result := AThread.ThreadID = GetCurrentThreadID;
end;

function IsNumeric(c: char): Boolean;
begin
  // Do not use IsCharAlpha or IsCharAlphaNumeric - they are Win32 routines
  Result := Pos(c, '0123456789') > 0; {do not localize}
end;

function StrToDay(const ADay: string): Byte;
begin
  Result := Succ(PosInStrArray(Uppercase(ADay),
    ['SUN','MON','TUE','WED','THU','FRI','SAT','SUN']));
end;

function StrToMonth(const AMonth: string): Byte;
begin
  Result := Succ(PosInStrArray(Uppercase(AMonth),
    ['JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP','OCT','NOV','DEC']));
end;

function UpCaseFirst(S: string): string;
begin
  Result := LowerCase(S);
  if Result <> '' then
  begin
    Result[1] := UpCase(Result[1]);
  end;
end;

function DateTimeToGmtOffSetStr(ADateTime: TDateTime; SubGMT: Boolean): string;
var
  AHour, AMin, ASec, AMSec: Word;

  function ZeroPad(S: string): string;
  begin
    if Length(S) < 2 then
    begin
      Result := '0' + S;  {do not localize}
    end
    else
    begin
      Result := S;
    end;
  end;

begin
  if (ADateTime = 0.0) and SubGMT then
  begin
    Result := 'GMT'; {do not localize}
    Exit;
  end;

  DecodeTime(ADateTime, AHour, AMin, ASec, AMSec);
  Result := CHAR32 + ZeroPad(IntToStr(AHour)) + ZeroPad(IntToStr(AMin));
  if ADateTime < 0.0 then
  begin
    Result[1] := '-'; {do not localize}
  end
  else
  begin
    Result[1] := '+';  {do not localize}
  end;
end;


procedure BuildMIMETypeMap(dest: TStringList);
var
  Reg: TRegistry;
  slSubKeys: TStringList;
  i: integer;
begin
  Reg := CreateTRegistry; try
    Reg.RootKey := HKEY_CLASSES_ROOT;
    Reg.OpenKeyreadOnly('\MIME\Database\Content Type'); {do not localize}
    slSubKeys := TStringList.Create;
    try
      Reg.GetKeyNames(slSubKeys);
      reg.Closekey;
      for i := 0 to slSubKeys.Count - 1 do
      begin
        Reg.OpenKeyreadOnly('\MIME\Database\Content Type\' + slSubKeys[i]);  {do not localize}
        dest.Append(LowerCase(reg.ReadString('Extension')) + '=' + slSubKeys[i]); {do not localize}
        Reg.CloseKey;
      end;
    finally
      slSubKeys.Free;
    end;
  finally
    reg.free;
  end;
end;

function GetMIMETypeFromFile(AFile: TFileName): string;
var
  MIMEMap: TPsiMIMETable;
begin
  MIMEMap := TPsiMimeTable.Create(true);
  try
    result := MIMEMap.GetFileMIMEType(AFile);
  finally
    MIMEMap.Free;
  end;
end;


procedure ParseURI(URI: string; Var Protocol, Host, path, Document, Port: string);
begin
  TPsiURI.ParseURI(URI, Protocol, Host, path, Document, Port);
end;

function GmtOffsetStrToDateTime(S: string): TDateTime;
begin
  Result := 0.0;
  S := Copy(Trim(s), 1, 5);
  if Length(S) > 0 then
  begin
    if s[1] in ['-', '+'] then
    begin
      try
        Result := EncodeTime(StrToInt(Copy(s, 2, 2)), StrToInt(Copy(s, 4, 2)), 0, 0);
        if s[1] = '-' then
        begin
          Result := -Result;
        end;
      except
        Result := 0.0;
      end;
    end;
  end;
end;

function GMTToLocalDateTime(S: string): TDateTime;
var  {-Always returns date/time relative to GMT!!  -Replaces StrInternetToDateTime}
  DateTimeOffset: TDateTime;
begin
  Result := RawStrInternetToDateTime(S);
  if Length(S) < 5 then begin
    DateTimeOffset := 0.0
  end else begin
    DateTimeOffset := GmtOffsetStrToDateTime(S);
  end;
  {-Apply GMT offset here}
  if DateTimeOffset < 0.0 then
  begin
    Result := Result + Abs(DateTimeOffset);
  end
  else
  begin
    Result := Result - DateTimeOffset;
  end;
  // Apply local offset
  Result := Result + OffSetFromUTC;
end;


procedure Sleep(ATime: cardinal);
begin
  windows.Sleep(ATime);
end;

{ Takes a cadinal (DWORD)  value and returns the string representation of it's binary value}
function IntToBin(Value: cardinal): string;
var
  i: Integer;
begin
  SetLength(result, 32);
  for i := 1 to 32 do
  begin
    if ((Value shl (i-1)) shr 31) = 0 then
      result[i] := '0'
    else
      result[i] := '1';
  end;
end;

function CurrentProcessId: integer;
begin
  Result := GetCurrentProcessID;
end;

function ROL(val : LongWord; shift : Byte) : LongWord; assembler;
asm
  mov  eax, val;
  mov  cl, shift;
  rol  eax, cl;
end;

function ROR(val : LongWord; shift : Byte) : LongWord; assembler;
asm
  mov  eax, val;
  mov  cl, shift;
  ror  eax, cl;
end;

procedure DebugOutput(const AText: string);
begin
  OutputDebugString(PChar(AText));
end;

function InMainThread: boolean;
begin
  result := GetCurrentThreadID = MainThreadID;
end;

{ TPsiMimeTable }

procedure TPsiMimeTable.BuildCache;
var
  reg: TRegistry;
  KeyList: TStringList;
  i: Integer;
begin
  // Build the file type/MIME type map
  Reg := CreateTRegistry; try
    KeyList := TStringList.create;
    try
      Reg.RootKey := HKEY_CLASSES_ROOT;
      Reg.OpenKeyReadOnly('\');
      Reg.GetKeyNames(KeyList);
      reg.Closekey;
      // get a list of registered extentions
      for i := 0 to KeyList.Count - 1 do
      begin
        if Copy(KeyList[i], 1, 1) = '.' then
        begin
          reg.OpenKeyReadOnly(KeyList[i]);
          if Reg.ValueExists('Content Type') then
          begin
            FFileExt.Values[KeyList[i]] := Reg.ReadString('Content Type');
          end;
          reg.CloseKey;
        end;
      end;
      Reg.OpenKeyreadOnly('\MIME\Database\Content Type');

      // get a list of registered MIME types
      KeyList.Clear;

      Reg.GetKeyNames(KeyList);
      reg.Closekey;
      for i := 0 to KeyList.Count - 1 do
      begin
        Reg.OpenKeyreadOnly('\MIME\Database\Content Type\' + KeyList[i]);
        FMIMEList.Values[reg.ReadString('Extension')] := KeyList[i];
        Reg.CloseKey;
      end;
    finally
      KeyList.Free;
    end;
  finally
    reg.free;
  end;
end;

constructor TPsiMimeTable.Create(Autofill: boolean);
begin
  FFileExt := TStringList.Create;
  FMIMEList := TStringList.Create;
  if Autofill then
    BuildCache;
end;

destructor TPsiMimeTable.Destroy;
begin
  FreeAndNil(FMIMEList);
  FreeAndNil(FFileExt);
  inherited;
end;

function TPsiMimeTable.getDefaultFileExt(const MIMEType: string): String;
begin
  result := FMIMEList.Values[MIMEType];
  if Length(result) = 0 then
  begin
    BuildCache;
    result := FMIMEList.Values[MIMEType];;
  end;
end;

function TPsiMimeTable.GetFileMIMEType(const fileName: String): String;
begin
  result := FFileExt.Values[ExtractFileExt(FileName)];
  if Length(result) = 0 then
  begin
    BuildCache;
    result := FMIMEList.Values[ExtractFileExt(FileName)];
    if Length(result) = 0 then
    begin
      result := 'application/octet-stream';{do not localize} 
    end;
  end;
end;

procedure SetThreadPriority(AThread: TThread; const APriority: TThreadPriority);
begin
  AThread.Priority := APriority;
end;

function URLDecode(psSrc: string): string;
var
  i : Integer;
  ESC: string[2];
  CharCode: integer;
begin
  Result := '';
  psSrc := StringReplace(psSrc, '+', ' ', [rfReplaceAll]);
  i := 1;
  while i <= Length(psSrc) do begin
    if psSrc[i] <> '%' then begin
      Result := Result + psSrc[i]
    end else begin
      Inc(i); // skip the % char
      ESC := Copy(psSrc, i, 2); // Copy the escape code
      Inc(i, 1); // Then skip it.
      try
        CharCode := StrToInt('$' + ESC);
        if (CharCode > 0) and (CharCode < 256) then
          Result := Result + Char(CharCode);
      except end;
    end;
    Inc(i);
  end;
end;

function URLEncode(const psSrc: string): string;
const
  UnsafeChars = ' *#%<>';
var
  i: Integer;
begin
  Result := '';
  for i := 1 to Length(psSrc) do begin
    if (AnsiPos(psSrc[i], UnsafeChars) > 0) or (psSrc[i] >= #$80) then
      Result := Result + '%' + IntToHex(Ord(psSrc[i]), 2)
    else
      Result := Result + psSrc[i];
  end;
end;

initialization
  ATempPath := TempPath;
finalization
  FPsiPorts.Free;
end.