www.pudn.com > EmailServer.zip > 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('System\CurrentControlSet\Services\Tcpip\Parameters', 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.