psiglobal.pas

一个delphi的p2p控件的源代码

unit PsiGlobal;

//******************************************************************************
// The original software is under
// Copyright (c) 1993 - 2000, Chad Z. Hower (Kudzu)
//   and the Indy Pit Crew - http://www.nevrona.com/Indy/
//
// Amended : November 2000, by Michael M. Michalak MACS for use with
// MorphTek.com Inc Peer to Peer Open Source Components - http://www.morphtek.com
//
//******************************************************************************

interface

{$I PsiCompilerDefines.inc}

{This should be the only unit with a reference to the OS specific units}

uses
  Classes,
  SysUtils;

const
  PsiTimeoutDefault = -1;
  PsiTimeoutInfinite = -2;

  wsOk = 1;
  wsErr = 0;

  PsiPORT_ECHO    = 7;
  PsiPORT_DISCARD = 9;
  PsiPORT_SYSTAT  = 11;
  PsiPORT_DAYTIME = 13;
  PsiPORT_NETSTAT = 15;
  PsiPORT_QOTD    = 17;
  PsiPORT_CHARGEN = 19; {UDP Server!}
  PsiPORT_FTP     = 21;
  PsiPORT_TELNET  = 23;
  PsiPORT_SMTP    = 25;
  PsiPORT_TIME    = 37;
  PsiPORT_WHOIS   = 43;
  PsiPORT_DOMAIN  = 53;
  PsiPORT_TFTP    = 69;
  PsiPORT_GOPHER  = 70;
  PsiPORT_FINGER  = 79;
  PsiPORT_HTTP    = 80;
  PsiPORT_HOSTNAME = 101;
  PsiPORT_POP2    = 109;
  PsiPORT_POP3    = 110;
  PsiPORT_AUTH    = 113;
  PsiPORT_NNTP    = 119;
  PsiPORT_SNTP    = 123;
  PsiPORT_IMAP4   = 143;
  PsiPORT_SSL     = 443;
  PsiPORT_LPD     = 515;
  PsiPORT_DICT    = 2628;
  PsiPORT_IRC     = 6667;


type


  TStringEvent = procedure(ASender: TComponent; const AString: String);

const
  gsPsiProductName = 'Indy';
  gsPsiVersion = '8.007B';
  LF = #10;
  CR = #13;
  EOL = CR + LF;
  BACKSPACE = #8;
  TAB = #9;
  CHAR0 = #0;
  CHAR32 = #32;

type
  TPsiMimeTable = Class
  protected
    FMIMEList: TStringList;
    FFileExt: TStringList;
  public
    procedure BuildCache; virtual;
    function GetFileMIMEType(const fileName: String): String;
    function getDefaultFileExt(Const MIMEType: string): String;
    constructor Create(Autofill: boolean=true); virtual;
    destructor Destroy; override;
  end;

  TCharSet = (csGB2312, csBig5, csIso2022jp, csEucKR, csIso88591);

// Procs - KEEP THESE ALPHABETICAL!!!!!
  {$IFNDEF VCL5ORABOVE}
  function AnsiSameText(const S1, S2: string): Boolean;
  function IncludeTrailingBackSlash(const APath: string): string;
  procedure FreeAndNil(var Obj);
  {$ENDIF}
  procedure BuildMIMETypeMap(dest: TStringList);
  procedure CommaSeperatedToStringList(AList: TStrings; const Value:string);
  function CopyFileTo(const Source, Destination: string): Boolean;
  function CurrentProcessId: integer;
  function DateTimeToGmtOffSetStr(ADateTime: TDateTime; SubGMT: Boolean): string;
  Function DateTimeToInternetStr(const Value: TDateTime) : String;
  procedure DebugOutput(const AText: string);
  function Fetch(var AInput: string; const ADelim: string = ' '; const ADelete: Boolean = true)
   : string;
  function FileSizeByName(sFilename: string): cardinal;
  function GetMIMETypeFromFile(AFile: TFileName): string;
  function GetSystemLocale: TCharSet;
  function GetTickCount: Cardinal;
  function GmtOffsetStrToDateTime(S: string): TDateTime;
  function IntToBin(Value: cardinal): string;
  function PsiPorts: TList;
  function IsCurrentThread(AThread: TThread): boolean;
  function IsNumeric(c: char): Boolean;
  function InMainThread: boolean;
  function Max(AValueOne,AValueTwo: Integer): Integer;
  function MakeTempFilename: string;
  function Min(AValueOne, AValueTwo : Integer): Integer;
  function OffsetFromUTC: TDateTime;
  procedure ParseURI(URI: string; Var Protocol, Host, path, Document, Port: string);
  function PosInStrArray(SearchStr: string; Contents: array of string; const CaseSensitive: Boolean=True): Integer;
  function RightStr(st : String; Len : Integer): String;
  function ROL(val: LongWord; shift: Byte): LongWord;
  function ROR(val: LongWord; shift: Byte): LongWord;
  function RPos(const ASub, AIn: String; AStart: Integer = -1): Integer;
  procedure SetLocalTime(Value: TDateTime);
  procedure SetThreadPriority(AThread: TThread; const APriority: TThreadPriority);
  procedure Sleep(ATime: cardinal);
  function StrInternetToDateTime(Value: string): TDateTime;
  function StrToDay(const ADay: string): Byte;
  function StrToMonth(const AMonth: string): Byte;
  function TimeZoneBias: Double;
  function UpCaseFirst(S: string): string;
  function GMTToLocalDateTime(S: string): TDateTime;
  function URLDecode(psSrc: string): string;
  function URLEncode(const psSrc: string): string;

implementation

uses
  Registry,
  Windows,
  PsiException,
  PsiResourceStrings,
  PsiURI;

const
  WhiteSpace = [#0..#12, #14..' '];

var
  FPsiPorts: TList;
  ATempPath: string;

{This is an internal procedure so the StrInternetToDateTime and GMTToLocalDateTime can share common code}
function RawStrInternetToDateTime(var Value: string): TDateTime;
var
  i: Integer;
  Dt, Mo, Yr, Ho, Min, Sec: Word;
  sTime: String;
begin
  Result := 0.0;
  Value := Trim(Value);
  if length(Value) = 0 then
  begin
    Exit;
  end;

  try
    {Day of Week}
    
    if StrToDay(Copy(Value, 1, 3)) > 0 then
    begin
      Fetch(Value);
    end;

    {Day of Month}
    Dt :=  StrToIntDef( Fetch(Value), 1);

    {Month}
    Mo := StrToMonth( Fetch ( Value ) );

    {Year}
    Yr := StrToIntDef ( Fetch ( Value ), 1900 );
    if Yr < 80 then
    begin
      Inc(Yr, 2000);
    end
    else
    if Yr < 100 then
    begin
      Inc(Yr, 1900);
    end;

    Result := EncodeDate(Yr, Mo, Dt);
    // SG 26/9/00: Canged so that ANY time format is accepted
    i := AnsiPos(':',Value);
    if i > 0 then
    begin
      // Copy time string up until next space (before GMT offset)
      sTime := fetch(Value, ' ');
      {Hour}
      Ho  := StrToIntDef( Fetch ( sTime,':'), 0);
      {Minute}
      Min := StrToIntDef( Fetch ( sTime,':'), 0);
      {Second}
      Sec := StrToIntDef( Fetch ( sTime ), 0);
      {The date and time stamp returned}
      Result := Result + EncodeTime(Ho, Min, Sec, 0);
    end;
  except
    Result := 0.0;
  end;
end;

{$IFNDEF VCL5ORABOVE}
function AnsiSameText(const S1, S2: string): Boolean;
begin
  Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PChar(S1)
   , Length(S1), PChar(S2), Length(S2)) = 2;
end;

function IncludeTrailingBackSlash(const APath: string): string;
begin
  Result := APath;
  if not IsPathDelimiter(Result, Length(Result)) then begin
    Result := Result + '\';
  end;
end;

procedure FreeAndNil(var Obj);
var
  P: TObject;
begin
  P := TObject(Obj);
  TObject(Obj) := nil;  // clear the reference before destroying the object
  P.Free;
end;
{$ENDIF}

  {$IFNDEF VCL5ORABOVE}
  function CreateTRegistry: TRegistry;
  begin
    Result := TRegistry.Create;
  end;
  {$ELSE}
  function CreateTRegistry: TRegistry;
  begin
    Result := TRegistry.Create(KEY_READ);
  end;
{$ENDIF}

function Max(AValueOne,AValueTwo: Integer): Integer;
begin
  if AValueOne < AValueTwo then
  begin
    Result := AValueTwo
  end //if AValueOne < AValueTwo then
  else
  begin
    Result := AValueOne;
  end; //else..if AValueOne < AValueTwo then
end;

function Min(AValueOne, AValueTwo : Integer): Integer;
begin
  If AValueOne > AValueTwo then
  begin
    Result := AValueTwo
  end //If AValueOne > AValueTwo then
  else
  begin
    Result := AValueOne;
  end; //..If AValueOne > AValueTwo then
end;

Function DateTimeToInternetStr(const Value: TDateTime) : String;
var
  strDate: String;
  wDay,
  wMonth,
  wYear:WORD;
  wHour,
  wMinute,
  wSecond,
  wMillasecond : Word;
begin
  {needed to prevent wild results}
  Result := '';
  // Date
  case DayOfWeek(Value) of
    1: strDate := 'Sun, '; {do not localize}
    2: strDate := 'Mon, '; {do not localize}
    3: strDate := 'Tue, ';  {do not localize}
    4: strDate := 'Wed, ';  {do not localize}
    5: strDate := 'Thu, ';  {do not localize}
    6: strDate := 'Fri, ';  {do not localize}
    7: strDate := 'Sat, ';   {do not localize}
  end;
  DecodeDate(Value, wYear, wMonth, wDay);
  strDate := strDate + IntToStr(wDay) + #32;
  case wMonth of
     1: strDate := strDate + 'Jan '; {do not localize}
     2: strDate := strDate + 'Feb '; {do not localize}
     3: strDate := strDate + 'Mar '; {do not localize}
     4: strDate := strDate + 'Apr '; {do not localize}
     5: strDate := strDate + 'May '; {do not localize}
     6: strDate := strDate + 'Jun '; {do not localize}
     7: strDate := strDate + 'Jul '; {do not localize}
     8: strDate := strDate + 'Aug '; {do not localize}
     9: strDate := strDate + 'Sep '; {do not localize}
    10: strDate := strDate + 'Oct '; {do not localize}
    11: strDate := strDate + 'Nov '; {do not localize}
    12: strDate := strDate + 'Dec '; {do not localize}
  end;
  DecodeTime(Value,wHour,wMinute,wSecond,wMillasecond);
  {This should never be localized}
  strDate := strDate + IntToStr(wYear) + #32 + Format('%0d:%0d:%0d',[wHour,wMinute,wSecond]);
  Result := strDate + #32 + DateTimeToGmtOffSetStr(OffsetFromUTC,False);
end;

function StrInternetToDateTime(Value: string): TDateTime;
begin
  Result := RawStrInternetToDateTime(Value);
end;

procedure CommaSeperatedToStringList(AList: TStrings; const Value:string);
var
  iStart,
  iEnd,
  iQuote,
  iPos,
  iLength : integer ;
  sTemp : string ;
begin
  iQuote := 0;
  iPos := 1 ;
  iLength := Length(Value) ;
  AList.Clear ;
  while (iPos <= iLength) do
  begin
    iStart := iPos ;
    iEnd := iStart ;
    while ( iPos <= iLength ) do
    begin
      if Value[iPos] = '"' then
      begin
        inc(iQuote);
      end;
      if Value[iPos] = ',' then
      begin
        if iQuote <> 1 then
        begin
          break;
        end;
      end;
      inc(iEnd);
      inc(iPos);
    end ;
    sTemp := Trim(Copy(Value, iStart, iEnd - iStart));
    if Length(sTemp) > 0 then
    begin
      AList.Add(sTemp);
    end;
    iPos := iEnd + 1 ;
    iQuote := 0 ;
  end ;
end;

function CopyFileTo(const Source, Destination: string): Boolean;
begin
  Result := CopyFile(PChar(Source), PChar(Destination), true);
end;

function TempPath: string;
var
	i: integer;
begin
  SetLength(Result, MAX_PATH);
	i := GetTempPath(Length(Result), PChar(Result));
	SetLength(Result, i);
  IncludeTrailingBackSlash(Result);
end;

function MakeTempFilename: string;
begin
  SetLength(Result, MAX_PATH + 1);
  GetTempFileName(PChar(ATempPath), 'Indy', 0, PChar(result));
  Result := PChar(Result);
end;

// Find a token given a direction (>= 0 from start; < 0 from end)
// S.G. 19/4/00:
//  Changed to be more readable
function RPos(const ASub, AIn: String; AStart: Integer = -1): Integer;
var
  i: Integer;
  LStartPos: Integer;
  LTokenLen: Integer;
begin
  result := 0;
  LTokenLen := Length(ASub);
  // Get starting position
  if AStart = -1 then begin
    AStart := Length(AIn);
  end;
  if AStart < (Length(AIn) - LTokenLen + 1) then begin
    LStartPos := AStart;
  end else begin
    LStartPos := (Length(AIn) - LTokenLen + 1);
  end;
  // Search for the string
  for i := LStartPos downto 1 do begin
    if AnsiSameText(Copy(AIn, i, LTokenLen), ASub) then begin
      result := i;
      break;
    end;
  end;
end;

function GetSystemLocale: TCharSet;
begin
  case SysLocale.PriLangID of
    LANG_CHINESE:
      if SysLocale.SubLangID = SUBLANG_CHINESE_SIMPLIFIED then
        Result := csGB2312
      else
        Result := csBig5;
    LANG_JAPANESE: Result := csIso2022jp;
    LANG_KOREAN: Result := csEucKR;
    else
      Result := csIso88591;
  end;
end;

// OS-independant version
function FileSizeByName(sFilename: string): cardinal;
var
  sFile: TFileStream;
begin
  sFile := TFileStream.Create(sFilename, fmOpenRead or fmShareDenyNone);
  try
    result := sFile.Size;
  finally
    sFile.free;
  end;
end;


Function RightStr(st : String; Len : Integer) : String;
begin
  if ( Len > Length ( st ) ) or ( Len < 0 ) then
  begin
    Result := st;
  end  //f ( Len > Length ( st ) ) or ( Len < 0 ) then
  else
  begin
    Result := Copy ( St, Length( st ) - Len, Len );
  end; //else ... f ( Len > Length ( st ) ) or ( Len < 0 ) then
end;

function OffsetFromUTC: TDateTime;
var
  iBias: Integer;
  tmez: TTimeZoneInformation;
begin
  Case GetTimeZoneInformation(tmez) of
    TIME_ZONE_ID_INVALID:
      raise EPsiException.Create(RSFailedTimeZoneInfo);
    TIME_ZONE_ID_UNKNOWN  :
       iBias := tmez.Bias;
    TIME_ZONE_ID_DAYLIGHT :
      iBias := tmez.Bias + tmez.DaylightBias;
    TIME_ZONE_ID_STANDARD :
      iBias := tmez.Bias + tmez.StandardBias;
    else
      raise EPsiException.Create(RSFailedTimeZoneInfo);