Email服务器

开发平台：
Delphi

UtilU1.pas：源码内容
							unit UtilU1;
(******************************************************************************)
(*                                                                            *)
(* SMTP General Application Utilities                                         *)
(* Part of Hermes SMTP/POP3 Server.                                           *)
(* Copyright(C) 2000 by Alexander J. Fanti, All Rights Reserver Worldwide.    *)
(*                                                                            *)
(* Contains: Route Parsing Utilities, File and Shell Operations, File Name    *)
(*           and Size tools, TimeZone utilities, etc.                         *)
(*                                                                            *)
(* Created January 10, 2000 by Alexander J. Fanti.  See License.txt           *)
(*                                                                            *)
(* Used by: most everything                                                   *)
(*                                                                            *)
(* Description: This little utility library contains all the miscelanious     *)
(*              utilities that don't belong anywhere else.                    *)
(*                                                                            *)
(* Revisions: 1/25/2000  AJF  Commented                                       *)
(*            1/28/2000  AJF  Added StringToInteger                           *)
(*                                                                            *)
(******************************************************************************)
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  FileCtrl, ShellAPI, Registry;
  function FileOperation(FromFile, ToFile : String; Operation : String):Boolean;
  function LaunchShellApp(CMDLine : String) : Boolean;
  function GetFileSize(Filename : String) : Longint;
  function GetUniqueFilename(Path : String) : String;
  function GetFileCountInDirectory(Path : String) : Longint;
  function GetFileSizeInDirectory(Path : String) : Longint;
  function IsDomainNumber(Domain : String) : Boolean;
  function IsDomainDottedIP(Domain : String) : Boolean;
  function IsDomainValid(Domain : String) : Boolean;
  function FormatedDomain(Domain : String) : String;
  function FormatedAtDomain(Domain : String) : String;
  function IsMailboxValid(Mailbox : String) : Boolean;
  function FormattedMailbox(Mailbox : String) : String;
  function FormatedAddress(Mailbox, Domain : String) : String;
  function IsAddressValid(EMailAddress : String) : Boolean;
  procedure FetchDNSList(DNSList : TStringList);
//  function AddTextToFile(FQFilename : String; Data : TStringList) : Boolean;
//  function AddTextToFile(FQFilename : String; Data : TStringList;
//                         MaxLines : Longint) : Boolean;
  function GetTimeZoneString : String;
  function StringToInteger(AString : String; DefaultInteger : Integer) :Integer;
implementation
function FileOperation(FromFile, ToFile : String; Operation : String) : Boolean;
var
  pFrom, pTo : PChar;
  FileOpStr : TSHFileOpStruct;
begin
  // Perform a Shell Operation (specifically, Copy, Move, Rename or Delete a
  // file or folder...
  FileOperation := False;
  pFrom := StrAlloc(Length(FromFile) +2);
  pTo   := StrAlloc(Length(ToFile) +2);
  StrPCopy(pFrom, FromFile);
  pFrom[Length(FromFile) +1] := #0;
  StrPCopy(pTo, ToFile);
  pTo[Length(ToFile) +1] := #0;
  FileOpStr.Wnd:= Application.Handle;
  if UpperCase(Operation) = 'COPY' then FileOpStr.wFunc:= FO_COPY;
  if UpperCase(Operation) = 'DELETE' then FileOpStr.wFunc:= FO_DELETE;
  if UpperCase(Operation) = 'MOVE' then FileOpStr.wFunc:= FO_MOVE;
  if UpperCase(Operation) = 'RENAME' then FileOpStr.wFunc:= FO_RENAME;
  FileOpStr.pFrom:= pFrom;
  FileOpStr.pTo:= pTo;
  FileOpStr.fFlags:= FOF_NOCONFIRMATION + FOF_SILENT + FOF_FILESONLY;
  FileOpStr.fAnyOperationsAborted:= False;
  FileOpStr.hNameMappings:= nil;
  FileOpStr.lpszProgressTitle:= nil;
  try
    if SHFileOperation(FileOpStr) = 0 then FileOperation := True;
  except
    on E: Exception do FileOperation := False;
  end;
  StrDispose(pFrom);
  StrDispose(pTo);
end;
(*
function StripFileExtension(FQFilename : String) : String;
var
  x : longint;
begin
  // Remove a file extension from
  StripFileExtension := FQFilename;
  x := Length(FQFilename);
  while (x > 0) and (Copy(FQFilename, x, 1) <> '.') do Dec(x);
  if Copy(FQFilename, x, 1) = '.' then
    StripFileExtension := Copy(FQFilename, 1, x -1);
end;
function WinExecAndWait32(FileName : String; Visibility : integer) : Boolean;
var
  zAppName : Array[0..512] of char;
  zCurDir : Array[0..255] of char;
  WorkDir : String;
  StartupInfo : TStartupInfo;
  ProcessInfo : TProcessInformation;
begin
  StrPCopy(zAppName, FileName) ;
  GetDir(0, WorkDir) ;
  StrPCopy(zCurDir,WorkDir) ;
  FillChar(StartupInfo, Sizeof(StartupInfo),#0) ;
  StartupInfo.cb := Sizeof(StartupInfo) ;
  StartupInfo.dwFlags := STARTF_USESHOWWINDOW ;
  StartupInfo.wShowWindow := Visibility ;
  if CreateProcess(nil,
      zAppName,                      { pointer to command line string }
      nil,                           { pointer to process security attributes}
      nil,                           { pointer to thread security attributes }
      False,                         { handle inheritance flag }
      CREATE_NEW_CONSOLE or          { creation flags }
      NORMAL_PRIORITY_CLASS,
      nil,                           { pointer to new environment block }
      nil,                           { pointer to current directory name }
      StartupInfo,                   { pointer to STARTUPINFO }
      ProcessInfo) then begin
    CloseHandle(ProcessInfo.hThread);
    WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
    // this should hang the app till the other closes...!
//    GetExitCodeProcess(ProcessInfo.hProcess, @tempInt);
    CloseHandle(ProcessInfo.hProcess);
    Result := True;
  end else begin
    // failed
    Result := False;
  end;
end;
*)
function LaunchShellApp(CMDLine : String) : Boolean;
var
  Info : TShellExecuteInfo;
  ErrorDescription : String;
  zCMDLine : Array[0..512] of char;
  zEXEName : Array[0..512] of char;
  zEXEPath : Array[0..512] of char;
begin
  StrPCopy(zCMDLine, CMDLine);
  StrPCopy(zEXEName, ExtractFilename(CMDLine));
  StrPCopy(zEXEPath, ExtractFilePath(CMDLine));
  Info.cbSize    := SizeOf(Info);
  Info.fMask     := SEE_MASK_FLAG_DDEWAIT +
                    SEE_MASK_NOCLOSEPROCESS +
                    SEE_MASK_FLAG_NO_UI;
  Info.Wnd       := Application.Handle;
  Info.lpVerb    := 'open';
  Info.lpFile    := zCMDLine;
  Info.lpParameters := '';
  Info.lpDirectory := '';
  Info.nShow     := SW_SHOWNORMAL;
  Info.hInstApp  := 0;
  Info.lpIDList  := nil;
  Info.lpClass   := nil;
  Info.hkeyClass := 0;
  Info.dwHotKey  := 0;
  Info.hIcon     := 0;
  Info.hProcess  := 0;
  Result := ShellExecuteEX(@Info);
  case Info.hInstApp of
    SE_ERR_FNF : ErrorDescription := 'File not found';
    SE_ERR_PNF : ErrorDescription := 'Path not found';
    SE_ERR_ACCESSDENIED : ErrorDescription := 'Access denied';
    SE_ERR_OOM : ErrorDescription := 'Out of memory';
    SE_ERR_DLLNOTFOUND : ErrorDescription := 'Dynamic-link library not found';
    SE_ERR_SHARE : ErrorDescription := 'Cannot share open file';
    SE_ERR_ASSOCINCOMPLETE : ErrorDescription := 'File association ' +
                                                 'information not complete';
    SE_ERR_DDETIMEOUT : ErrorDescription := 'DDE operation timed out';
    SE_ERR_DDEFAIL : ErrorDescription := 'DDE operation failed';
    SE_ERR_DDEBUSY : ErrorDescription := 'DDE operation busy';
    SE_ERR_NOASSOC : ErrorDescription := 'File association not available';
  end;
end;
(*
function LaunchShellAppwP(CMDLine, Parameters : String) : Boolean;
var
  Info : TShellExecuteInfo;
  ErrorDescription : String;
  zCMDLine : Array[0..512] of char;
  zEXEName : Array[0..512] of char;
  zEXEPath : Array[0..512] of char;
  zParameters : Array[0..512] of char;
begin
  StrPCopy(zCMDLine, CMDLine);
  StrPCopy(zEXEName, ExtractFilename(CMDLine));
  StrPCopy(zEXEPath, ExtractFilePath(CMDLine));
  StrPCopy(zParameters, Trim(Parameters));
  Info.cbSize    := SizeOf(Info);
  Info.fMask     := SEE_MASK_FLAG_DDEWAIT +
                    SEE_MASK_NOCLOSEPROCESS +
                    SEE_MASK_FLAG_NO_UI;
  Info.Wnd       := Application.Handle;
  Info.lpVerb    := 'open';
  Info.lpFile    := zEXEName;
  Info.lpParameters := zParameters;
  Info.lpDirectory := zEXEPath;
  Info.nShow     := SW_SHOWNORMAL;
  Info.hInstApp  := 0;
  Info.lpIDList  := nil;
  Info.lpClass   := nil;
  Info.hkeyClass := 0;
  Info.dwHotKey  := 0;
  Info.hIcon     := 0;
  Info.hProcess  := 0;
  Result := ShellExecuteEX(@Info);
  case Info.hInstApp of
    SE_ERR_FNF : ErrorDescription := 'File not found';
    SE_ERR_PNF : ErrorDescription := 'Path not found';
    SE_ERR_ACCESSDENIED : ErrorDescription := 'Access denied';
    SE_ERR_OOM : ErrorDescription := 'Out of memory';
    SE_ERR_DLLNOTFOUND : ErrorDescription := 'Dynamic-link library not found';
    SE_ERR_SHARE : ErrorDescription := 'Cannot share open file';
    SE_ERR_ASSOCINCOMPLETE : ErrorDescription := 'File association ' +
                                                 'information not complete';
    SE_ERR_DDETIMEOUT : ErrorDescription := 'DDE operation timed out';
    SE_ERR_DDEFAIL : ErrorDescription := 'DDE operation failed';
    SE_ERR_DDEBUSY : ErrorDescription := 'DDE operation busy';
    SE_ERR_NOASSOC : ErrorDescription := 'File association not available';
  end;
end;
*)
function GetFileSize(Filename : String) : Longint;
// Return the file size in bytes.
// Return -1 if file does not exist...
var
  F : File of Byte;
begin
  // Return size of a file in bytes
  Result := -1;
  if FileExists(Filename) then begin
    AssignFile(F, Filename);
    try
      Reset(F);
      Result := FileSize(F);
    except
      on E: Exception do Result := -1;
    end;
    CloseFile(F);
  end;
end;
function GetUniqueFilename(Path : String) : String;
// returns just a file name that's unique in the given path
// Regardless of extension
var
  SearchRec : TSearchRec;
  SearchResult : longint;
  Filename : String;
begin
  if Copy(Path, Length(Path), 1) <> '' then Path := Path + '';
  ForceDirectories(Path);
  SearchResult := 0;
  while SearchResult = 0 do begin
    // generate filename...
    Filename := IntToStr(Random(99999));
    // see if it exists?
    SearchResult := FindFirst(Path + Filename + '.*', faAnyFile, SearchRec);
    FindClose(SearchRec);
  end;
  Result := Filename;
end;
function GetFileCountInDirectory(Path : String) : Longint;
var
  SearchRec : TSearchRec;
  SearchResult : longint;
  Count : Longint;
begin
  Count := 0;
  if Copy(Path, Length(Path), 1) <> '' then Path := Path + '';
  if DirectoryExists(Path) then begin
    SearchResult := FindFirst(Path + '*.*', 0, SearchRec);
    while SearchResult = 0 do begin
      Inc(Count);
      SearchResult := FindNext(SearchRec);
    end;
    FindClose(SearchRec);
  end;
  Result := Count;
end;
function GetFileSizeInDirectory(Path : String) : Longint;
var
  SearchRec : TSearchRec;
  SearchResult : longint;
  Size, OneSize : Longint;
begin
  Size := 0;
  if Copy(Path, Length(Path), 1) <> '' then Path := Path + '';
  if DirectoryExists(Path) then begin
    SearchResult := FindFirst(Path + '*.*', 0, SearchRec);
    while SearchResult = 0 do begin
      OneSize := GetFileSize(Path + SearchRec.Name);
      if OneSize > 0 then Inc(Size, OneSize);
      SearchResult := FindNext(SearchRec);
    end;
    FindClose(SearchRec);
  end;
  Result := Size;
end;
(*********************)
(* Address Utilities *)
(*********************)
function IsDomainNumber(Domain : String) : Boolean;
var
  x : Longint;
begin
  Result := True;
  for x := 1 to Length(Domain) do
    if not ((Copy(Domain, x, 1) >= '0') and (Copy(Domain, x, 1) <= '9')) then
      Result := False;
end;
function IsDomainDottedIP(Domain : String) : Boolean;
var
  x : Longint;
  DotCount : Byte;
  T, A, B, C, D : String;
  An, Bn, Cn, Dn : Integer;
begin
  DotCount := 0;   // Check three dots
  for x := 1 to Length(Domain) do
    if Copy(Domain, x, 1) = '.' then Inc(DotCount);
  if DotCount = 3 then begin
    // verify each dot seperates a byte value
    T := Domain;
    A := Copy(T, 1, Pos('.', T) -1);
    T := Copy(T, Pos('.', T) +1, Length(T));
    B := Copy(T, 1, Pos('.', T) -1);
    T := Copy(T, Pos('.', T) +1, Length(T));
    C := Copy(T, 1, Pos('.', T) -1);
    D := Copy(T, Pos('.', T) +1, Length(T));
    try
      An := StrToInt(A);
      Bn := StrToInt(B);
      Cn := StrToInt(C);
      Dn := StrToInt(D);
      Result := True;
      if not ((An >= 0) and (An <= 255)) then Result := False;
      if not ((Bn >= 0) and (Bn <= 255)) then Result := False;
      if not ((Cn >= 0) and (Cn <= 255)) then Result := False;
      if not ((Dn >= 0) and (Dn <= 255)) then Result := False;
    except
      on E: Exception do Result := False;
    end;
  end else Result := False;  // wrong number of .
end;
function IsDomainValid(Domain : String) : Boolean;
// Check for invalid characters.  valid chars are 0..9, a..z, A..Z and .
var
  x : Longint;
begin
  Result := True;
  for x := 1 to Length(Domain) do
    if (not ((Copy(Domain, x, 1) >= '0') and (Copy(Domain, x, 1) <= '9'))) and
       (not ((Copy(Domain, x, 1) >= 'a') and (Copy(Domain, x, 1) <= 'z'))) and
       (not ((Copy(Domain, x, 1) >= 'A') and (Copy(Domain, x, 1) <= 'Z'))) and
       (not (Copy(Domain, x, 1) = '-')) and
       (not (Copy(Domain, x, 1) = '.')) then Result := False;
end;
function FormatedDomain(Domain : String) : String;
begin
  Result := '';
  if IsDomainValid(Domain) then
    if IsDomainNumber(Domain) then Result := '#' + Domain else
      if IsDomainDottedIP(Domain) then Result := '[' + Domain + ']'
        else Result := Domain;
end;
function FormatedAtDomain(Domain : String) : String;
begin
  Result := '';
  if IsDomainValid(Domain) then
    if IsDomainNumber(Domain) then Result := '@#' + Domain
      else if IsDomainDottedIP(Domain) then Result := '@[' + Domain + ']'
        else Result := '@' + Domain;
end;
// What are valid mailbox characters?
// DEBUG
function IsMailboxValid(Mailbox : String) : Boolean;
// Check for invalid characters.  valid chars are 0..9, a..z, A..Z and .
//var
//  x : Longint;
begin
  Result := True;
//for x := 1 to Length(Mailbox) do
//  if (not ((Copy(Mailbox, x, 1) >= '0') and (Copy(Mailbox, x, 1) <= '9'))) and
//     (not ((Copy(Mailbox, x, 1) >= 'a') and (Copy(Mailbox, x, 1) <= 'z'))) and
//     (not ((Copy(Mailbox, x, 1) >= 'A') and (Copy(Mailbox, x, 1) <= 'Z'))) and
//     (not (Copy(Mailbox, x, 1) = '.')) then Result := False;
end;
function FormattedMailbox(Mailbox : String) : String;
var
  x : Longint;
  Quoted : Boolean;
begin
  if IsMailboxValid(Mailbox) then begin
    Quoted := False;
    for x := 1 to Length(Mailbox) do
      if Copy(Mailbox, x, 1) = ' ' then Quoted := True;
    if Quoted then Result := '"' + Mailbox + '"'
      else Result := Mailbox;
  end else Result := '';
end;
function FormatedAddress(Mailbox, Domain : String) : String;
begin
  Result := FormattedMailbox(Mailbox) + FormatedAtDomain(Domain);
end;
function IsAddressValid(EMailAddress : String) : Boolean;
var
  Mailbox, Domain : String;
begin
  Result := False;
  if Pos('@', EMailAddress) > 0 then begin
    // parse to mailbox and domain...
    Mailbox := Copy(EMailAddress, 1, Pos('@', EMailAddress) -1);
    Domain  := Copy(EMailAddress, Pos('@', EMailAddress) +1,
                    Length(EMailAddress));
    Result := IsMailBoxValid(Mailbox) and IsDomainValid(Domain);
  end;
end;
procedure FetchDNSList(DNSList : TStringList);
var
  Reg : TRegistry;
  tempStr : String;
begin
  if Assigned(DNSList) then begin
    DNSList.Clear;
    Reg := TRegistry.Create;
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if Reg.OpenKey('SystemCurrentControlSetServicesTcpipParameters', False) then begin
      // Read Static Name Servers...
      tempStr := Reg.ReadString('NameServer');
      if tempStr <> '' then begin
        while (Pos(',', tempStr) <> 0) or (Pos(' ', tempStr) <> 0) do begin
          DNSList.Add(Trim( Copy(tempStr, 1, Pos(',', tempStr)-1) ));
          tempStr := Copy(tempStr, Pos(',', tempStr)+1, Length(tempStr) );
        end;
        DNSList.Add( tempStr );
      end;
      // Read DHCP Name Servers...
      tempStr := Reg.ReadString('DHCPNameServer');
      if tempStr <> '' then begin
        while Pos(' ', tempStr) <> 0 do begin
          DNSList.Add(Trim( Copy(tempStr, 1, Pos(' ', tempStr)-1) ));
          tempStr := Copy(tempStr, Pos(' ', tempStr)+1, Length(tempStr) );
        end;
        DNSList.Add( tempStr );
      end;
    end;
    Reg.Free;
  end;
end;
(*
function AddTextToFile(FQFilename : String; Data : TStringList) : Boolean;
var
  F : TextFile;
  x : Longint;
begin
  if Assigned(Data) then begin
    AssignFile(F, FQFilename);
    try
      Append(F);
      for x := 0 to Data.Count -1 do Writeln(F, Data[x]);
    except
      on E: Exception do try
        ReWrite(F);
        for x := 0 to Data.Count -1 do Writeln(F, Data[x]);
      except
        on E: Exception do begin end;
      end;
    end;
    CloseFile(F);
  end;
end;
*)
(*
function AddTextToFile(FQFilename : String; Data : TStringList;
                       MaxLines : Longint) : Boolean;
// Open a text file... add lines to it... truncate if too long.
// This is used by message archive... it's too slow for logging.
var
  x, Drop : Longint;
  SL : TStringList;
begin
  Result := False;
  if Assigned(Data) and (FQFilename <> '') then begin
    SL := TStringList.Create;
    try
      SL.LoadFromFile(FQFilename)
    except
      on E: Exception do begin end;
    end;
    for x := 0 to Data.Count -1 do SL.Add(Data[x]);
    if MaxLines > 0 then
      if MaxLines < SL.Count then begin
        Drop := SL.Count -(MaxLines +1);
        while (Drop >= 0) and (SL.Count > 0) do begin
          SL.Delete(0);
          Dec(Drop);
        end;
      end;
    try
      SL.SaveToFile(FQFilename);
      Result := True;
    except
      on E: Exception do begin end;
    end;
    SL.Free;
  end;
end;
*)
function GetTimeZoneString : String;
// Make a string representing the user's time zone (GMT+5:00)
var
  x, TimeZone : Longint;
  TimeZoneStr : String;
  TZInfo : TTimeZoneInformation;
  TZSignStr, TZHourStr, TZMinuteStr, TZZoneStr : String;
  OrigTZHour, TZHour, TZMinute : Integer;
begin
  x := GetTimeZoneInformation(TZInfo);
  TimeZone := TZInfo.Bias;
  if x = TIME_ZONE_ID_STANDARD then
    TimeZone := -(TZInfo.Bias + TZInfo.StandardBias);
  if x = TIME_ZONE_ID_DAYLIGHT then
    TimeZone := -(TZInfo.Bias + TZInfo.DaylightBias);
  OrigTZHour := -(TZInfo.Bias div 60);
  if TimeZone >= 0 then TimeZoneStr := '+';
  TimeZoneStr := TimeZoneStr + IntToStr(TimeZone div 60) + ':' +
    Copy('0' + IntToStr(TimeZone mod 60), 1, 2);
  // Old Style
  Result := 'GMT' + TimeZoneStr;
  // New Style
  if TimeZone >= 0 then TZSignStr := '+';
  TZHour := TimeZone div 60;
  TZHourStr := '0' + IntToStr(TZHour);
  TZHourStr := Copy(TZHourStr, Length(TZHourStr) -1, 2);
  TZMinute := TimeZone mod 60;
  TZMinuteStr := '0' + IntToStr(TZMinute);
  TZMinuteStr := Copy(TZMinuteStr, Length(TZMinuteStr) -1, 2);
  case OrigTZHour of
    -12 : TZZoneStr := '()';
    -11 : TZZoneStr := '()';
     -9 : TZZoneStr := '()';
     -8 : TZZoneStr := '()';
     -7 : TZZoneStr := '()';
     -6 : TZZoneStr := '()';
     -5 : TZZoneStr := '()'; // EST
     -4 : TZZoneStr := '()';
     -3 : TZZoneStr := '()';
     -2 : TZZoneStr := '()';
     -1 : TZZoneStr := '()';
      0 : TZZoneStr := '';
      1 : TZZoneStr := '()';
      2 : TZZoneStr := '()';
      3 : TZZoneStr := '()';
      4 : TZZoneStr := '()';
      5 : TZZoneStr := '()';
      6 : TZZoneStr := '()';
      7 : TZZoneStr := '()';
      8 : TZZoneStr := '()';
      9 : TZZoneStr := '()';
     10 : TZZoneStr := '()';
     11 : TZZoneStr := '()';
     12 : TZZoneStr := '()';
     else TZZoneStr := '';
  end;
  if Length(TZZoneStr) <= 2 then TZZoneStr := '';
  Result := TZSignStr + TZHourStr + ':' + TZMinuteStr + ' ' + TZZoneStr;
end;
function StringToInteger(AString : String; DefaultInteger : Integer) : Integer;
// Convert a string to an integer, but capture errors and replace with a default
var
  x : Integer;
begin
  try
    x := StrToInt(AString);
  except
    on E: Exception do x := DefaultInteger;
  end;
  Result := x;
end;
end.

						