DataU1.pas
上传用户:dh8233980
上传日期:2014-10-16
资源大小:1015k
文件大小:104k
- unit DataU1;
- (******************************************************************************)
- (* *)
- (* SMTP Server Data Objects *)
- (* Part of Hermes SMTP/POP3 Server. *)
- (* Copyright(C) 2000 by Alexander J. Fanti, All Rights Reserver Worldwide. *)
- (* *)
- (* Contains: TServerInformation, TPop3UserInformation, TPop3MailInformation *)
- (* TMailListInformation, TMessageRouteInformation *)
- (* *)
- (* Created January 13, 2000 by Alexander J. Fanti. See License.txt *)
- (* *)
- (* Depends on: UtilU1 *)
- (* Also Uses: WSocket (Francois Piette Internet Component Suite) *)
- (* *)
- (* Used by: Virtually everything *)
- (* *)
- (* Description: *)
- (* TServerInformation - This is the Server Application's main Object. It *)
- (* contains ALL data relevant to the server (ports to *)
- (* use, bind addresses, etc.). It can load and save *)
- (* this data, and manage it. It also exposes services *)
- (* that other objects use to interpret this data. *)
- (* TPop3UserInformation - This object is used to manipulate a single user. *)
- (* It contains all relevant user data, and can load *)
- (* and save this data. It also allows manitulation of *)
- (* the data, and exposes some services. *)
- (* TPop3MailInformation - This object is used to collect and interpret *)
- (* information about a single user's mailbox. It can *)
- (* get a list of messages and deal with them (delete, *)
- (* etc). *)
- (* TMailListInformation - This object is used to manipulate a single mail *)
- (* list. It contains all list data, cal load and save *)
- (* the data and exposes services to interpret and *)
- (* manage the data. *)
- (* TMessageRouteInformation - This object is used to manipulate a mail route. *)
- (* The route is in the format specified by the SMTP*)
- (* RFC (<@domain,@[IPAddress]:"mailbox"@domain>) *)
- (* It can parse a string into a route, and can *)
- (* assemble a string from a route. *)
- (* *)
- (* Revisions: 1/29/2000 AJF Commented *)
- (* 2/12/2000 AJF Added Start Minimized *)
- (* 2/12/2000 AJF Added Data and Interface to manage Smtp Server *)
- (* access (for anti-spam) *)
- (* 2/13/3000 AJF Added Startup options *)
- (* 3/11/2000 AJF Added DNS Timeout and Process Queue on Startup *)
- (* *)
- (******************************************************************************)
- interface
- uses Windows, Messages, Classes, SysUtils, FileCtrl, INIFiles;
- const
- AppVersion = '1.4.0.0'; // Application Version (for About Dialog)
- AppWebSite = 'http://www.alixoft.com'; // App Web site.
- AuthorEMail = 'mailto:alex@alixoft.com'; // my email address
- ServerRoot = 'C:Program FilesAlixoftHermes';
- ALIASSEPERATOR = '<==>'; // constant used to seperate AliasID and AliasUser
- // in Alias String internal storage
- INVALIDNAMECHARACTERS = '( ) < > @ , ; : " [ ]'; // These cannpt appear
- // in a mailbox name
- // Status Levels, used in StatusUpdate events to indicate the "level"
- // of the status message
- STAT_CRITICALERROR = 0;
- STAT_SERVERERROR = 1;
- STAT_SERVEREVENT = 2;
- STAT_CONNECTIONERROR = 3;
- STAT_CONNECTIONEVENT = 4;
- STAT_COMMANDERROR = 5;
- STAT_COMMANDEVENT = 6;
- STAT_PROCESSINGERROR = 7;
- STAT_PROCESSINGEVENT = 8;
- type
- TBannerLevel = (bannerlevel_NameVersionService, bannerlevel_NameService, bannerlevel_Service);
- TServerInformation = class(TObject)
- private
- FAppPath : String;
- FStartMinimized : Boolean; // True if user wants to start minimized...
- FStartProcessQueueOnStartup : Boolean; // if True, then process queue on start
- // True if we're to start whatever on startup
- FAutoStart_SmtpServer : Boolean;
- FAutoStart_SmtpAgent : Boolean;
- FAutoStart_Pop3Server : Boolean;
- FServerName : String; // Used by Pop3Server for APOP ID,
- // SmtpServer for it's domain and domain of users
- // SmtpAgent as it's Domain when connect to others
- FMailBoxPath : String; // Pop3 Users folders are here ( terminated)
- // (username = foldername)
- // one file = username.ini is user settings.
- // all other files are mail to be delivered
- FMailListPath : String; // Mail list folder. Each mail list is storred
- // here by listname.ini ( terminated)
- FMailQueuePath : String; // Incoming mail (from SMTP) that must be delivered
- // non-local goes here for Agent files are
- // ###.ini (message info) and ###.txt (message)
- // ( terminated)
- FDNSServerAddress : String; // IP address of DNS server to use for
- // MX domain resolution
- FDNSServerTimeout : Integer; // Number of seconds SMTP Agent waits
- // for DNS to answer
- FFQLogFilename : String; // Fully qualified Log file to log everything to...
- FLogLevel : Integer; // The number (and below) of events to report
- FLogSpyMessageContent : Boolean;
- FBanner_Level : TBannerLevel;
- FPop3_BindAddress : String; // Bind address (to listen to)
- FPop3_Port : Integer; // Port to listen to
- FPop3_CreateUserOnDemand : Boolean; // if TRUE we make user folder
- // and info on login
- FPop3_CreateUserPasswordOnDemand: Boolean; // if true we change password to
- // whatever's supplied (if blank)
- FPop3_InactivityTimeout : Integer; // Inactivity Timeout in Minutes
- FSmtp_BindAddress : String; // Bind address (to listen to)
- FSmtp_Port : Integer; // Port to listen to
- FSmtp_Domains : TStringList; // List of Domains the SMTP server will
- // accept mail for
- FSmtp_Retries : Integer; // How many retries do we attempt on a
- // message we're trying to forward?
- // These are for access control for the Smtp Server (who can send, etc.)
- FSmtp_Access_BanDomains : Boolean; // reject mail from "banned" domains
- FSmtp_Access_BanMailboxes : Boolean; // reject mail from "banned" mailboxes
- FSmtp_Access_BanAddresses : Boolean; // reject mail from "banned" Addresses
- FSmtp_Access_OnlyForUnderXUsers : Boolean; // Accept mail only if To count
- FSmtp_Access_OnlyForUsersCount : Longint; // is lower than this!
- FSmtp_Access_Restricted : Boolean;
- FSmtp_Access_AcceptedDomains : TStringList; // List of Domains the server
- // will accept mail from
- FSmtp_Access_BannedMailBoxes : TStringList; // List of mailboxes the server
- // will reject mail from
- FSmtp_Access_BannedDomains : TStringList; // List of Domains the SMTP
- // server will accept mail from
- FSmtp_Access_BannedAddresses : TStringList; // List of Addresses the SMTP
- // server will accept mail from
- // (connection)
- FSmtp_InactivityTimeout : Integer; // Inactivity Timeout in Minutes
- FAgent_PollingInterval : Longint; // Time in seconds between polls...
- FAgent_ServiceQueueImmediately : Boolean; // if true, post message to make
- // queue fire immediately
- FAgent_ForwardToMasterSMTP : Boolean; // True if we don't try to deliver,
- // but just forward
- FAgent_MasterServerIPAddress : String; // The dotted IP address of the SMTP
- // server to forward to.
- FAgent_InactivityTimeout : Integer; // Inactivity Timeout in Minutes
- FUser_Aliases : TStringList; // Alias<==>UserID format stringlist
- procedure SetMailBoxPath(Path : String);
- procedure SetMailListPath(Path : String);
- procedure SetMailQueuePath(Path : String);
- procedure SetAgentPollingInterval(Interval : Longint);
- public
- constructor Create;
- destructor Destroy; Override;
- procedure Initialize;
- function Exists : Boolean;
- function LoadFromFile : Boolean;
- function SaveToFile : Boolean;
- property Pop3_BindAddress : String
- read FPop3_BindAddress write FPop3_BindAddress;
- property Pop3_Port : Integer
- read FPop3_Port write FPop3_Port;
- property Pop3_CreateUserOnDemand : Boolean
- read FPop3_CreateUserOnDemand write FPop3_CreateUserOnDemand;
- property Pop3_CreateUserPasswordOnDemand : Boolean
- read FPop3_CreateUserPasswordOnDemand
- write FPop3_CreateUserPasswordOnDemand;
- property Pop3_InactivityTimeout : Integer
- read FPop3_InactivityTimeout write FPop3_InactivityTimeout;
- property Smtp_BindAddress : String
- read FSmtp_BindAddress write FSmtp_BindAddress;
- property Smtp_Port : Integer
- read FSmtp_Port write FSmtp_Port;
- property Smtp_Domains : TStringList read FSmtp_Domains;
- procedure SetSmtp_Domains(Strings : TStrings);
- property Smtp_Access_AcceptedDomains : TStringList
- read FSmtp_Access_AcceptedDomains;
- procedure SetSmtp_Access_AcceptedDomains(Strings : TStrings);
- property Smtp_Access_BannedMailboxes : TStringList
- read FSmtp_Access_BannedMailboxes;
- procedure SetSmtp_Access_BannedMailBoxes(Strings : TStrings);
- property Smtp_Access_BannedDomains : TStringList
- read FSmtp_Access_BannedDomains;
- procedure SetSmtp_Access_BannedDomains(Strings : TStrings);
- property Smtp_Access_BannedAddresses : TStringList
- read FSmtp_Access_BannedAddresses;
- procedure SetSmtp_Access_BannedAddresses(Strings : TStrings);
- property Smtp_Retries : Integer read FSmtp_Retries write FSmtp_Retries;
- property Smtp_InactivityTimeout : Integer
- read FSmtp_InactivityTimeout write FSmtp_InactivityTimeout;
- property Agent_PollingInterval : Longint
- read FAgent_PollingInterval write SetAgentPollingInterval;
- property Agent_ServiceQueueImmediately : Boolean
- read FAgent_ServiceQueueImmediately
- write FAgent_ServiceQueueImmediately;
- property Agent_ForwardToMasterSMTP : Boolean
- read FAgent_ForwardToMasterSMTP write FAgent_ForwardToMasterSMTP;
- property Agent_MasterServerIPAddress : String
- read FAgent_MasterServerIPAddress write FAgent_MasterServerIPAddress;
- property Agent_InactivityTimeout : Integer
- read FAgent_InactivityTimeout write FAgent_InactivityTimeout;
- function Domain_IsThisOneOfMine(Domain : String) : Boolean;
- function MailBox_IsThisOneOfMine(Mailbox : String) : Boolean;
- function Smtp_Access_IsThisDomainAccepted(Domain : String) : Boolean;
- function Smtp_Access_IsThisMailboxBanned(Mailbox : String) : Boolean;
- function Smtp_Access_IsThisDomainBanned(Domain : String) : Boolean;
- function Smtp_Access_IsThisAddressBanned(Address : String) : Boolean;
- property Smtp_Access_BanDomains : Boolean
- read FSmtp_Access_BanDomains write FSmtp_Access_BanDomains;
- property Smtp_Access_BanAddresses : Boolean
- read FSmtp_Access_BanAddresses write FSmtp_Access_BanAddresses;
- property Smtp_Access_BanMailboxes : Boolean
- read FSmtp_Access_BanMailboxes write FSmtp_Access_BanMailboxes;
- property Smtp_Access_OnlyForUnderXUsers : Boolean
- read FSmtp_Access_OnlyForUnderXUsers
- write FSmtp_Access_OnlyForUnderXUsers;
- property Smtp_Access_OnlyForUsersCount : Longint
- read FSmtp_Access_OnlyForUsersCount
- write FSmtp_Access_OnlyForUsersCount;
- property Smtp_Access_Restricted : Boolean
- read FSmtp_Access_Restricted write FSmtp_Access_Restricted;
- property StartMinimized : Boolean
- read FStartMinimized write FStartMinimized;
- property ProcessQueueOnStartup : Boolean
- read FStartProcessQueueOnStartup write FStartProcessQueueOnStartup;
- property AutoStart_SmtpServer : Boolean
- read FAutoStart_SmtpServer write FAutoStart_SmtpServer;
- property AutoStart_SmtpAgent : Boolean
- read FAutoStart_SmtpAgent write FAutoStart_SmtpAgent;
- property AutoStart_Pop3Server : Boolean
- read FAutoStart_Pop3Server write FAutoStart_Pop3Server;
- property AppPath : String read FAppPath;
- property ServerName : String read FServerName write FServerName;
- property MailBoxPath : String read FMailBoxPath write SetMailBoxPath;
- property MailListPath : String read FMailListPath write SetMailListPath;
- property MailQueuePath : String read FMailQueuePath write SetMailQueuePath;
- property DNSServerAddress : String
- read FDNSServerAddress write FDNSServerAddress;
- property DNSServerTimeout : Integer read FDNSServerTimeout write FDNSServerTimeout;
- property LogFile : String read FFQLogFilename write FFQLogFilename;
- property LogLevel : Integer read FLogLevel write FLogLevel;
- property LogSpyMessageContent : Boolean read FLogSpyMessageContent write FLogSpyMessageContent;
- property Banner_Level : TBannerLevel read FBanner_Level write FBanner_Level;
- function TimeStamp : String;
- procedure User_GetList(Strings : TStrings);
- function User_Exists(UserName : String) : Boolean;
- function User_Create(UserName : String) : Boolean;
- function User_Delete(UserName : String) : Boolean;
- function User_Rename(OldUserName, NewUserName : String) : Boolean;
- procedure List_GetList(Strings : TStrings);
- function List_Exists(ListName : String) : Boolean;
- function List_Create(ListName : String) : Boolean;
- function List_Delete(ListName : String) : Boolean;
- function List_Rename(OldListName, NewListName : String) : Boolean;
- procedure Alias_Parse(AliasString : String; var AliasID : String;
- var AliasUser : String);
- procedure Alias_SetList(Strings : TStrings);
- procedure Alias_GetList(Strings : TStrings);
- function Alias_Exists(AliasIDorAlias : String) : Boolean;
- function Alias_Create(AliasID, AliasUser : String) : Boolean;
- procedure Alias_Delete(AliasIDorAlias : String);
- function Alias_Rename(OldAliasIDorAlias, NewAliasID : String) : Boolean;
- function Alias_Find(AliasIDorAlias : String) : String;
- function Alias_Edit(AliasIDorAlias, NewAliasUser : String) : Boolean;
- end;
- TPop3UserInformation = class(TObject)
- private
- FUserName : String;
- FPassword : String;
- FForwardToAddress : String;
- FRealName : String;
- FUB_DoNotReportUserExists_SMTP : Boolean; // SMTP VRFY will fail
- FLimit_MessageToBytes, FLimit_MailboxToBytes, FLimit_MailboxToMessages : Longint;
- public
- constructor Create;
- destructor Destroy; Override;
- property UserName : String read FUserName;
- property Password : String read FPassword write FPassword;
- property ForwardToAddress : String
- read FForwardToAddress write FForwardToAddress;
- property RealName : String read FRealName write FRealName;
- property UB_DoNotReportUserExists_SMTP : Boolean
- read FUB_DoNotReportUserExists_SMTP
- write FUB_DoNotReportUserExists_SMTP;
- property Limit_MessageToBytes : Longint read FLimit_MessageToBytes write FLimit_MessageToBytes;
- property Limit_MailboxToBytes : Longint read FLimit_MailboxToBytes write FLimit_MailboxToBytes;
- property Limit_MailboxToMessages : Longint read FLimit_MailboxToMessages write FLimit_MailboxToMessages;
- procedure Initialize;
- function LoadFromFile(UserName : String) : Boolean;
- function SaveToFile(UserName : String) : Boolean; Overload;
- function SaveToFile : Boolean; Overload;
- function SaveMail(SL : TStringList) : Boolean;
- end;
- TMailListMemberInfoRec = record
- Active : Boolean; // True if this member is active
- Manager : Boolean; // True if this member is a manager
- EMail : String[255]; // address of member (may be local)
- // Unsupported as of now... /
- Hidden : Boolean; // True if member address must not be listed
- // by listserver. Does not affect SMTP EXPN command
- end;
- PMailListMemberInfoRec = ^TMailListMemberInfoRec;
- TMailListPendingMemberInfoRec = record
- ExpirationDate : TDateTime; // after this date... they can't join
- // (and must be purged)
- EMail : String[255]; // address of member (may be local)
- MagicNumber : Integer; // the number they must match to really get
- // subscribed
- end;
- PMailListPendingMemberInfoRec = ^TMailListPendingMemberInfoRec;
- TMailListInformation = class(TObject)
- private
- FFileDateTime : TDateTime; // File Date so we can tell if it was edited
- // since we opened it (for save purposes)
- FMembers : TList; // List of members (PMailListMemberInfoRec)
- FPendingMembers : TList; // List of pending members
- // (PMailListPendingMemberInfoRec)
- FPassword : String; // Required in some list commands (in mail body)
- FErrorsMailedTo : String; // e-mail address to send errors to...
- FFile_Welcome : String; // File send on subscription to list
- FFile_Signature : String; // File appended to every mail sent from list
- FFile_Farewell : String; // File sent on removal from list
- FSL_Welcome : TStringList; // Strings sent on subscription to list
- FSL_Signature : TStringList; // Strings appended to each mail sent from list
- FSL_Farewell : TStringList; // Strings sent on removal from list
- // List Behaviors
- FLB_AllowPublicSubscription : Boolean; // Anyone can subscribe to list
- // (as opposed to managers
- // subscribing people)
- FLB_ForceRepliesToList : Boolean; // Change mail (Reply To to
- // list address
- FLB_DoNotReportListMembers_SMTP : Boolean; // EXPN Command will fail
- FLB_DoNotReportListExists : Boolean; // List Lists command will omit
- FLB_DoNotReportListMembers : Boolean; // List Member command will fail
- FLB_MemberSubmissionOnly : Boolean; // Only members or managers may
- // mail to list
- FArchiveFile : String; // Keep copy of all list messages
- // (append to this file)
- function GetMembers(Index : Longint) : PMailListMemberInfoRec;
- function GetMemberCount : Longint;
- function GetPendingMembers(Index : Longint) : PMailListPendingMemberInfoRec;
- function GetPendingMemberCount : Longint;
- public
- constructor Create;
- destructor Destroy; Override;
- procedure Initialize;
- function LoadFromFile(ListName : String) : Boolean;
- function SaveToFile(ListName : String; Force : Boolean) : Boolean;
- property Members[Index : Longint] : PMailListMemberInfoRec read GetMembers;
- property MemberCount : Longint read GetMemberCount;
- function MemberAdd(Active, Manager : Boolean; EMail : String) :
- PMailListMemberInfoRec;
- procedure MemberDelete(Index : Longint);
- procedure MembersClear;
- property PendingMembers[Index : Longint] : PMailListPendingMemberInfoRec
- read GetPendingMembers;
- property PendingMemberCount : Longint read GetPendingMemberCount;
- function PendingMemberAdd(ExpirationDate : TDateTime;
- MagicNumber : Integer; EMail : String)
- : PMailListPendingMemberInfoRec;
- procedure PendingMemberDelete(Index : Longint); Overload;
- procedure PendingMemberDelete(TargetListMember
- : PMailListPendingMemberInfoRec); Overload;
- procedure PendingMembersClear;
- function PendingMember_FindByMagicNumber(MagicNumber : Integer)
- : PMailListPendingMemberInfoRec;
- function PendingMember_NewMagicNumber : Integer;
- property Password : String read FPassword write FPassword;
- property ErrorsMailedTo : String read FErrorsMailedTo write FErrorsMailedTo;
- property File_Welcome : String read FFile_Welcome write FFile_Welcome;
- property File_Signature : String read FFile_Signature write FFile_Signature;
- property File_Farewell : String read FFile_Farewell write FFile_Farewell;
- property SL_Welcome : TStringList read FSL_Welcome;
- procedure SetSL_Welcome(Strings : TStrings);
- property SL_Signature : TStringList read FSL_Signature;
- procedure SetSL_Signature(Strings : TStrings);
- property SL_Farewell : TStringList read FSL_Farewell;
- procedure SetSL_Farewell(Strings : TStrings);
- property LB_AllowPublicSubscription : Boolean
- read FLB_AllowPublicSubscription write FLB_AllowPublicSubscription;
- property LB_ForceRepliesToList : Boolean
- read FLB_ForceRepliesToList write FLB_ForceRepliesToList;
- property LB_DoNotReportListMembers_SMTP : Boolean
- read FLB_DoNotReportListMembers_SMTP
- write FLB_DoNotReportListMembers_SMTP;
- property LB_DoNotReportListExists : Boolean
- read FLB_DoNotReportListExists write FLB_DoNotReportListExists;
- property LB_DoNotReportListMembers : Boolean
- read FLB_DoNotReportListMembers write FLB_DoNotReportListMembers;
- property LB_MemberSubmissionOnly : Boolean
- read FLB_MemberSubmissionOnly write FLB_MemberSubmissionOnly;
- property ArchiveFile : String read FArchiveFile write FArchiveFile;
- end;
- TPop3MailEntry = record
- Number : Longint;
- Filename : String[255];
- FileSize : Longint;
- MarkForDelete : Boolean;
- end;
- PPop3MailEntry = ^TPop3MailEntry;
- TPop3MailInformation = class(TObject)
- private
- FFolderPath : String; // Set on "ReadFolder" and used on
- // "DeleteMarkedMessages" and "SaveToFile"
- FMail : TList;
- function GetCount : Longint;
- function GetDeletedCount : Longint;
- function GetByteCount : Longint;
- function GetMailEntry(Index: Integer) : PPop3MailEntry;
- procedure DropAllMail;
- public
- constructor Create;
- destructor Destroy; Override;
- procedure ReadFolder(UserName : String);
- function DeleteMarkedMessages : Longint;
- property Mail[Index: Integer] : PPop3MailEntry read GetMailEntry;
- function Find(ID : Integer) : PPop3MailEntry;
- property Count : Longint read GetCount;
- property CountDeleted : Longint read GetDeletedCount;
- property ByteCount : Longint read GetByteCount;
- end;
- TMessageRouteInformation_Kind = (mrte_Unknown, mrte_To, mrte_From);
- TMessageRouteInformation = class(TObject)
- private
- FKind : TMessageRouteInformation_Kind;
- FHosts : TStringList; // The list of hosts the mail has been through
- // 0 = left most in list, Count -1 = right most in list
- // if mode = To then Host 0 = you or next domain to send to
- // if mode = From then Host 0 = last domain sent from
- // (who sent you mail)
- FMailbox : String; // The mailbox the mail is from or to
- FDomain : String; // The domain the mail is from or to
- public
- constructor Create(Kind : TMessageRouteInformation_Kind);
- destructor Destroy; Override;
- procedure Initialize;
- function ParseRoute(Route : String) : Integer;
- function BuildRoute : String;
- property Kind : TMessageRouteInformation_Kind read FKind;
- property Domain : String read FDomain;
- property Mailbox : String read FMailbox;
- property Hosts : TStringList read FHosts;
- end;
- PMessageRouteInformation = ^TMessageRouteInformation;
- TWHComponent_WindowsMessage = procedure(Sender : TObject; Msg: TMessage)
- of object;
- TWHComponent = class(TComponent)
- private
- FHandle : HWnd;
- FWindowsMessage : TWHComponent_WindowsMessage;
- function GetWindowHandle(Obj : TObject) : HWnd;
- procedure WinProc(var Msg: TMessage);
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- property Handle : HWND read FHandle;
- property OnWindowsMessage : TWHComponent_WindowsMessage
- read FWindowsMessage write FWindowsMessage;
- end;
- function IsNameValid(Name : String) : Boolean;
- function IsNameValidIncludingAt(Name : String) : Boolean;
- function StatusLevelDescription(Level : Integer) : String;
- var
- INI : TServerInformation;
- implementation
- uses UtilU1, WSocket {For Local IP list only};
- constructor TServerInformation.Create;
- begin
- inherited Create;
- Randomize;
- FAppPath := IncludeTrailingBackslash(ServerRoot);
- FSmtp_Domains := TStringList.Create;
- FSmtp_Access_AcceptedDomains := TStringList.Create;
- FSmtp_Access_BannedMailBoxes := TStringList.Create;
- FSmtp_Access_BannedDomains := TStringList.Create;
- FSmtp_Access_BannedAddresses := TStringList.Create;
- FUser_Aliases := TStringList.Create;
- Initialize;
- end;
- destructor TServerInformation.Destroy;
- begin
- FSmtp_Domains.Free;
- FSmtp_Access_AcceptedDomains.Free;
- FSmtp_Access_BannedMailBoxes.Free;
- FSmtp_Access_BannedDomains.Free;
- FSmtp_Access_BannedAddresses.Free;
- FUser_Aliases.Free;
- inherited Destroy;
- end;
- procedure TServerInformation.Initialize;
- begin
- FStartMinimized := False;
- FStartProcessQueueOnStartup := False;
- FAutoStart_SmtpServer := True;
- FAutoStart_SmtpAgent := True;
- FAutoStart_Pop3Server := True;
- FServerName := 'Unknown';
- if LocalIPList.Count > 0 then FServerName := LocalIPList[0];
- MailBoxPath := FAppPath + 'UserMail';
- MailListPath := FAppPath + 'UserMail';
- MailQueuePath := FAppPath + 'MQueue';
- FDNSServerAddress := '';
- FDNSServerTimeout := 15;
- FPop3_BindAddress := '0.0.0.0';
- FPop3_Port := 110;
- FPop3_CreateUserOnDemand := False;
- FPop3_CreateUserPasswordOnDemand := False;
- FPop3_InactivityTimeout := 15;
- FSmtp_BindAddress := '0.0.0.0';
- FSmtp_Port := 25;
- FSmtp_Domains.Clear;
- FSmtp_Access_AcceptedDomains.Clear;
- FSmtp_Access_BannedMailBoxes.Clear;
- FSmtp_Access_BannedDomains.Clear;
- FSmtp_Access_BannedAddresses.Clear;
- FSmtp_Access_BanDomains := False;
- FSmtp_Access_BanAddresses := False;
- FSmtp_Access_BanMailboxes := False;
- // FSmtp_Access_AcceptAcceptableDomains := False;
- // FSmtp_Access_AcceptFromLocalDomains := False;
- // FSmtp_Access_AcceptFromLocalUsers := False;
- // FSmtp_Access_OnlyForLocalUsers := False;
- FSmtp_Access_OnlyForUnderXUsers := False;
- FSmtp_Access_OnlyForUsersCount := 10000;
- FSmtp_Access_Restricted := False;
- FSmtp_Retries := 5;
- FSmtp_InactivityTimeout := 15;
- // FSmtp_Forward := True;
- FUser_Aliases.Clear;
- FAgent_ForwardToMasterSMTP := False;
- FAgent_MasterServerIPAddress := '';
- FAgent_InactivityTimeout := 15;
- end;
- procedure TServerInformation.SetMailBoxPath(Path : String);
- begin
- // Be certain path is terminated
- if Copy(Path, Length(Path), 1) <> '' then Path := Path + '';
- // Be certain path exists
- if not DirectoryExists(Path) then try
- ForceDirectories(Path);
- except
- on E: Exception do begin {what to do if path can't be created ?} end;
- end;
- FMailBoxPath := Path;
- end;
- procedure TServerInformation.SetMailListPath(Path : String);
- begin
- // Be certain path is terminated
- if Copy(Path, Length(Path), 1) <> '' then Path := Path + '';
- // Be certain path exists
- if not DirectoryExists(Path) then try
- ForceDirectories(Path);
- except
- on E: Exception do begin {what to do if path can't be created ?} end;
- end;
- FMailListPath := Path;
- end;
- procedure TServerInformation.SetMailQueuePath(Path : String);
- begin
- // Be certain path is terminated
- if Copy(Path, Length(Path), 1) <> '' then Path := Path + '';
- // Be certain path exists
- if not DirectoryExists(Path) then try
- ForceDirectories(Path);
- except
- on E: Exception do begin {what to do if path can't be created ?} end;
- end;
- FMailQueuePath := Path;
- end;
- procedure TServerInformation.SetAgentPollingInterval(Interval : Longint);
- begin
- // Interval is specified in seconds
- if Interval > 36000 then Interval := 36000; // never more than 10 hours
- if Interval < 10 then Interval := 10; // never less than 10 seconds
- FAgent_PollingInterval := Interval;
- end;
- procedure TServerInformation.SetSmtp_Domains(Strings : TStrings);
- var
- x : Longint;
- begin
- if Assigned(Strings) then begin
- FSmtp_Domains.Clear;
- for x := 0 to Strings.Count -1 do FSmtp_Domains.Add(Strings[x]);
- end;
- end;
- procedure TServerInformation.SetSmtp_Access_AcceptedDomains(Strings : TStrings);
- var
- x : Longint;
- begin
- if Assigned(Strings) then begin
- FSmtp_Access_AcceptedDomains.Clear;
- for x := 0 to Strings.Count -1 do
- FSmtp_Access_AcceptedDomains.Add(Strings[x]);
- end;
- end;
- procedure TServerInformation.SetSmtp_Access_BannedMailBoxes(Strings : TStrings);
- var
- x : Longint;
- begin
- if Assigned(Strings) then begin
- FSmtp_Access_BannedMailBoxes.Clear;
- for x := 0 to Strings.Count -1 do
- FSmtp_Access_BannedMailBoxes.Add(Strings[x]);
- end;
- end;
- procedure TServerInformation.SetSmtp_Access_BannedDomains(Strings : TStrings);
- var
- x : Longint;
- begin
- if Assigned(Strings) then begin
- FSmtp_Access_BannedDomains.Clear;
- for x := 0 to Strings.Count -1 do
- FSmtp_Access_BannedDomains.Add(Strings[x]);
- end;
- end;
- procedure TServerInformation.SetSmtp_Access_BannedAddresses(Strings : TStrings);
- var
- x : Longint;
- begin
- if Assigned(Strings) then begin
- FSmtp_Access_BannedAddresses.Clear;
- for x := 0 to Strings.Count -1 do
- FSmtp_Access_BannedAddresses.Add(Strings[x]);
- end;
- end;
- function TServerInformation.Domain_IsThisOneOfMine(Domain : String) : Boolean;
- var
- x : Longint;
- Found : Boolean;
- begin
- Found := False;
- Domain := LowerCase(Trim(Domain)); // we must be case insensitive !
- if Domain <> '' then begin
- if Domain = INI.ServerName then Found := True
- else begin
- x := 0;
- while (not Found) and (x < FSmtp_Domains.Count) do
- if LowerCase(FSmtp_Domains[x]) = Domain then Found := True
- else Inc(x);
- end;
- end;
- Result := Found;
- end;
- function TServerInformation.MailBox_IsThisOneOfMine(Mailbox : String) : Boolean;
- begin
- Result := FileExists(INI.MailBoxPath + MailBox + '' + MailBox + '.ini');
- end;
- function TServerInformation.Smtp_Access_IsThisDomainAccepted(Domain : String)
- : Boolean;
- var
- x : Longint;
- Found : Boolean;
- OurDomain : String;
- begin
- Found := False;
- Domain := LowerCase(Trim(Domain)); // we must be case insensitive !
- if Domain <> '' then begin
- x := 0;
- while (not Found) and (x < FSmtp_Access_AcceptedDomains.Count) do begin
- OurDomain := LowerCase(FSmtp_Access_AcceptedDomains[x]);
- if Pos('*', OurDomain) > 0 then begin
- OurDomain := Copy(OurDomain, 1, Pos('*', OurDomain) -1);
- if OurDomain = Copy(Domain, 1, Length(OurDomain)) then Found := True
- else Inc(x);
- end else begin
- if OurDomain = Domain then Found := True
- else Inc(x);
- end;
- end;
- end;
- Result := Found;
- end;
- function TServerInformation.Smtp_Access_IsThisMailboxBanned(Mailbox : String)
- : Boolean;
- var
- x : Longint;
- Found : Boolean;
- OurMailbox : String;
- begin
- Found := False;
- Mailbox := LowerCase(Trim(Mailbox)); // we must be case insensitive !
- if Mailbox <> '' then begin
- x := 0;
- while (not Found) and (x < FSmtp_Access_BannedMailBoxes.Count) do begin
- OurMailbox := LowerCase(FSmtp_Access_BannedMailBoxes[x]);
- if Pos('*', OurMailbox) > 0 then begin
- OurMailbox := Copy(OurMailbox, 1, Pos('*', OurMailbox) -1);
- if OurMailbox = Copy(Mailbox, 1, Length(OurMailbox)) then Found := True
- else Inc(x);
- end else begin
- if OurMailbox = Mailbox then Found := True
- else Inc(x);
- end;
- end;
- end;
- Result := Found;
- end;
- function TServerInformation.Smtp_Access_IsThisDomainBanned(Domain : String)
- : Boolean;
- var
- x : Longint;
- Found : Boolean;
- OurDomain : String;
- begin
- Found := False;
- Domain := LowerCase(Trim(Domain)); // we must be case insensitive !
- if Domain <> '' then begin
- x := 0;
- while (not Found) and (x < FSmtp_Access_BannedDomains.Count) do begin
- OurDomain := LowerCase(FSmtp_Access_BannedDomains[x]);
- if Pos('*', OurDomain) > 0 then begin
- OurDomain := Copy(OurDomain, 1, Pos('*', OurDomain) -1);
- if OurDomain = Copy(Domain, 1, Length(OurDomain)) then Found := True
- else Inc(x);
- end else begin
- if OurDomain = Domain then Found := True
- else Inc(x);
- end;
- end;
- end;
- Result := Found;
- end;
- function TServerInformation.Smtp_Access_IsThisAddressBanned(Address : String)
- : Boolean;
- var
- x : Longint;
- Found : Boolean;
- OurAddress : String;
- begin
- Found := False;
- Address := LowerCase(Trim(Address)); // we must be case insensitive !
- if Address <> '' then begin
- x := 0;
- while (not Found) and (x < FSmtp_Access_BannedAddresses.Count) do begin
- OurAddress := LowerCase(FSmtp_Access_BannedAddresses[x]);
- if Pos('*', OurAddress) > 0 then begin
- OurAddress := Copy(OurAddress, 1, Pos('*', OurAddress) -1);
- if OurAddress = Copy(Address, 1, Length(OurAddress)) then Found := True
- else Inc(x);
- end else begin
- if OurAddress = Address then Found := True
- else Inc(x);
- end;
- end;
- end;
- Result := Found;
- end;
- function ReturnShortDay(Day : Word) : String;
- begin
- case Day of
- 1: Result := 'Sun';
- 2: Result := 'Mon';
- 3: Result := 'Tue';
- 4: Result := 'Wed';
- 5: Result := 'Thu';
- 6: Result := 'Fri';
- 7: Result := 'Sat';
- end;
- end;
- function ReturnShortMonth(Month : Word) : String;
- begin
- case Month of
- 1: Result := 'Jan';
- 2: Result := 'Feb';
- 3: Result := 'Mar';
- 4: Result := 'Apr';
- 5: Result := 'May';
- 6: Result := 'Jun';
- 7: Result := 'Jul';
- 8: Result := 'Aug';
- 9: Result := 'Sep';
- 10: Result := 'Oct';
- 11: Result := 'Nov';
- 12: Result := 'Dec';
- end;
- end;
- function TServerInformation.TimeStamp : String;
- var
- Year, Month, Day: Word;
- begin
- // Format = DD Mon YR HH:MM:SS Zone
- // Result := FormatDateTime('dd mmm yy hh:mm:ss', Now) + ' ' + GetTimeZoneString;
- // Format = Day, DD Mon YEAR HH:MM:SS Zone
- // Result := FormatDateTime('ddd, d mmm yyyy hh:mm:ss', Now) + ' ' + GetTimeZoneString;
- DecodeDate(Date, Year, Month, Day);
- Result := ReturnShortDay(DayOfWeek(Date)) + ', ' + IntToStr(Day) + ' ' + ReturnShortMonth(Month) + ' ' + IntToStr(Year) + ' ' + FormatDateTime('hh:mm:ss', Time) + ' ' + GetTimeZoneString;
- end;
- function TServerInformation.Exists : Boolean;
- begin
- Result := FileExists(AppPath + 'Hermes.ini');
- end;
- function TServerInformation.LoadFromFile : Boolean;
- var
- Filename : String;
- FINI : TINIFile;
- x : Longint;
- tempStr : String;
- begin
- Filename := AppPath + 'Hermes.ini';
- try
- FINI := TINIFile.Create(Filename);
- try
- FStartMinimized := FINI.ReadBool('General', 'Start Minimized', False);
- FStartProcessQueueOnStartup := FINI.ReadBool('General', 'Process Queue on Start', False);
- FAutoStart_SmtpServer := FINI.ReadBool('General',
- 'AutoStart Smtp Server', True);
- FAutoStart_SmtpAgent := FINI.ReadBool('General',
- 'AutoStart Smtp Agent', True);
- FAutoStart_Pop3Server := FINI.ReadBool('General',
- 'AutoStart Pop3 Server', True);
- FServerName := FINI.ReadString('General', 'Server Name', '');
- if (FServerName = '') and (LocalIPList.Count > 0) then
- FServerName := LocalIPList[0];
- FMailboxPath := FINI.ReadString('Directories', 'Mail Box Path',
- AppPath + 'UserMail');
- if FMailboxPath = '' then FMailboxPath := AppPath + 'UserMail';
- if not DirectoryExists(FMailboxPath) then
- ForceDirectories(FMailboxPath);
- FMailQueuePath := FINI.ReadString('Directories', 'Queue Path',
- AppPath + 'MQueue');
- if FMailQueuePath = '' then FMailQueuePath := AppPath + 'MQueue';
- if not DirectoryExists(FMailQueuePath) then
- ForceDirectories(FMailQueuePath);
- FMailListPath := FINI.ReadString('Directories', 'Mailing List Path',
- AppPath + 'UserMail');
- if FMailListPath = '' then FMailListPath := AppPath + 'UserMail';
- if not DirectoryExists(FMailListPath) then
- ForceDirectories(FMailListPath);
- FDNSServerAddress := FINI.ReadString('General', 'DNS Server Address', '');
- if FDNSServerAddress <> '' then
- if not IsDomainDottedIP(FDNSServerAddress) then FDNSServerAddress := '';
- FDNSServerTimeout := FINI.ReadInteger('General', 'DNS Server Timeout', 15);
- FFQLogFilename := FINI.ReadString('General', 'Log File', '');
- FLogLevel := FINI.ReadInteger('General', 'Log Level', 0);
- FLogSpyMessageContent := FINI.ReadBool('General', 'Log Message Spy', False);
- FBanner_Level := bannerlevel_NameVersionService;
- tempStr := UpperCase(Trim(FINI.ReadString('General', 'Banner Level', '')));
- if tempStr = 'Service' then FBanner_Level := bannerlevel_Service;
- if tempStr = 'Name and Service' then FBanner_Level := bannerlevel_NameService;
- // Pop3 Server Settings
- FPop3_BindAddress := FINI.ReadString('Pop 3 Server', 'Bind Address',
- '0.0.0.0');
- if FPop3_BindAddress = '' then FPop3_BindAddress := '0.0.0.0';
- FPop3_Port := FINI.ReadInteger('Pop 3 Server', 'Listen Port', 110);
- if FPop3_Port < 1 then FPop3_Port := 110;
- FPop3_CreateUserOnDemand := FINI.ReadBool('Pop 3 Server',
- 'Create User On Demand', False);
- FPop3_CreateUserPasswordOnDemand := FINI.ReadBool('Pop 3 Server',
- 'Create User Password On Demand',
- False);
- FPop3_InactivityTimeout := FINI.ReadInteger('Pop 3 Server',
- 'Inactivity Timeout (in minutes)', 15);
- // Smtp Server Settings
- FSmtp_BindAddress := FINI.ReadString('Smtp Server', 'Bind Address',
- '0.0.0.0');
- if FSmtp_BindAddress = '' then FSmtp_BindAddress := '0.0.0.0';
- FSmtp_Port := FINI.ReadInteger('Smtp Server', 'Listen Port', 25);
- if FSmtp_Port < 1 then FSmtp_Port := 25;
- FSmtp_Domains.Clear;
- FINI.ReadSectionValues('Smtp Server Domains', FSmtp_Domains);
- // Clean out "x="
- for x := 0 to FSmtp_Domains.Count -1 do
- if Pos('=', FSmtp_Domains[x]) > 0 then
- FSmtp_Domains[x] := Copy(FSmtp_Domains[x],
- Pos('=', FSmtp_Domains[x]) +1,
- Length(FSmtp_Domains[x]));
- FSmtp_InactivityTimeout := FINI.ReadInteger('Smtp Server',
- 'Inactivity Timeout (in minutes)', 15);
- // SMTP Server Access
- FSmtp_Access_AcceptedDomains.Clear;
- FINI.ReadSectionValues('Smtp Server Access - Accepted Domains',
- FSmtp_Access_AcceptedDomains);
- for x := 0 to FSmtp_Access_AcceptedDomains.Count -1 do
- if Pos('=', FSmtp_Access_AcceptedDomains[x]) > 0 then
- FSmtp_Access_AcceptedDomains[x]
- := Copy(FSmtp_Access_AcceptedDomains[x],
- Pos('=', FSmtp_Access_AcceptedDomains[x]) +1,
- Length(FSmtp_Access_AcceptedDomains[x]));
- FSmtp_Access_BannedMailBoxes.Clear;
- FINI.ReadSectionValues('Smtp Server Access - Banned Mailboxes',
- FSmtp_Access_BannedMailBoxes);
- for x := 0 to FSmtp_Access_BannedMailBoxes.Count -1 do
- if Pos('=', FSmtp_Access_BannedMailBoxes[x]) > 0 then
- FSmtp_Access_BannedMailBoxes[x]
- := Copy(FSmtp_Access_BannedMailBoxes[x],
- Pos('=', FSmtp_Access_BannedMailBoxes[x]) +1,
- Length(FSmtp_Access_BannedMailBoxes[x]));
- FSmtp_Access_BannedDomains.Clear;
- FINI.ReadSectionValues('Smtp Server Access - Banned Domains',
- FSmtp_Access_BannedDomains);
- for x := 0 to FSmtp_Access_BannedDomains.Count -1 do
- if Pos('=', FSmtp_Access_BannedDomains[x]) > 0 then
- FSmtp_Access_BannedDomains[x]
- := Copy(FSmtp_Access_BannedDomains[x],
- Pos('=', FSmtp_Access_BannedDomains[x]) +1,
- Length(FSmtp_Access_BannedDomains[x]));
- FSmtp_Access_BannedAddresses.Clear;
- FINI.ReadSectionValues('Smtp Server Access - Banned Addresses',
- FSmtp_Access_BannedAddresses);
- for x := 0 to FSmtp_Access_BannedAddresses.Count -1 do
- if Pos('=', FSmtp_Access_BannedAddresses[x]) > 0 then
- FSmtp_Access_BannedAddresses[x]
- := Copy(FSmtp_Access_BannedAddresses[x],
- Pos('=', FSmtp_Access_BannedAddresses[x]) +1,
- Length(FSmtp_Access_BannedAddresses[x]));
- FSmtp_Access_BanDomains := FINI.ReadBool('Smtp Server Access Control',
- 'Ban Domains', False);
- FSmtp_Access_BanAddresses := FINI.ReadBool('Smtp Server Access Control',
- 'Ban Addresses', False);
- FSmtp_Access_BanMailboxes := FINI.ReadBool('Smtp Server Access Control',
- 'Ban Mailboxes', False);
- // FSmtp_Access_AcceptAcceptableDomains := FINI.ReadBool(
- // 'Smtp Server Access Control',
- // 'Accepted Domains', False);
- // FSmtp_Access_AcceptFromLocalDomains := FINI.ReadBool(
- // 'Smtp Server Access Control',
- // 'Local Domains Only', False);
- // FSmtp_Access_AcceptFromLocalUsers := FINI.ReadBool(
- // 'Smtp Server Access Control',
- // 'Local Mailboxes Only', False);
- // FSmtp_Access_OnlyForLocalUsers := FINI.ReadBool(
- // 'Smtp Server Access Control',
- // 'For Local Mailboxes Only', False);
- FSmtp_Access_OnlyForUnderXUsers := FINI.ReadBool(
- 'Smtp Server Access Control',
- 'Apply To Maximum', False);
- FSmtp_Access_OnlyForUsersCount := FINI.ReadInteger(
- 'Smtp Server Access Control',
- 'To Maximum', 1000);
- FSmtp_Access_Restricted := FINI.ReadBool('Smtp Server Access Control',
- 'Restrict', False);
- // FSmtp_Forward := FINI.ReadBool('Smtp Server', 'Forward Mail', True);
- FSmtp_Retries := FINI.ReadInteger('Smtp Server', 'Forward Retries', 5);
- // Agent information
- FAgent_PollingInterval := FINI.ReadInteger('Smtp Agent',
- 'Polling Interval (in seconds)', 300);
- FAgent_ServiceQueueImmediately := FINI.ReadBool('Smtp Agent',
- 'Fire Queue Immediately', False);
- FAgent_ForwardToMasterSMTP := FINI.ReadBool('Smtp Agent',
- 'Forward to Master SMTP Server', False);
- FAgent_MasterServerIPAddress := FINI.ReadString('Smtp Agent',
- 'Master SMTP Server', '');
- FAgent_InactivityTimeout := FINI.ReadInteger('Smtp Agent',
- 'Inactivity Timeout (in minutes)', 15);
- FUser_Aliases.Clear;
- FINI.ReadSectionValues('User EMail Aliases', FUser_Aliases);
- // Clean out "x="
- for x := 0 to FUser_Aliases.Count -1 do
- if Pos('=', FUser_Aliases[x]) > 0 then
- FUser_Aliases[x] := Copy(FUser_Aliases[x],
- Pos('=', FUser_Aliases[x]) +1,
- Length(FUser_Aliases[x]));
- finally
- FINI.Free;
- end;
- Result := True;
- except
- on E: Exception do Result := False;
- end;
- end;
- function TServerInformation.SaveToFile : Boolean;
- var
- Filename : String;
- FINI : TINIFile;
- x : Longint;
- begin
- Filename := AppPath + 'Hermes.ini';
- try
- FINI := TINIFile.Create(Filename);
- try
- FINI.WriteBool('General', 'Start Minimized', FStartMinimized);
- FINI.WriteBool('General', 'Process Queue on Start', FStartProcessQueueOnStartup);
- FINI.WriteBool('General', 'AutoStart Smtp Server', FAutoStart_SmtpServer);
- FINI.WriteBool('General', 'AutoStart Smtp Agent', FAutoStart_SmtpAgent);
- FINI.WriteBool('General', 'AutoStart Pop3 Server', FAutoStart_Pop3Server);
- FINI.WriteString('General', 'Server Name', FServerName);
- FINI.WriteString('Directories', 'Mail Box Path', FMailboxPath);
- FINI.WriteString('Directories', 'Queue Path', FMailQueuePath);
- FINI.WriteString('Directories', 'Mailing List Path', FMailListPath);
- FINI.WriteString('General', 'DNS Server Address', FDNSServerAddress);
- FINI.WriteInteger('General', 'DNS Server Timeout', FDNSServerTimeout);
- FINI.WriteString('General', 'Log File', FFQLogFilename);
- FINI.WriteInteger('General', 'Log Level', FLogLevel);
- FINI.WriteBool('General', 'Log Message Spy', FLogSpyMessageContent);
- case FBanner_Level of
- bannerlevel_NameVersionService : FINI.WriteString('General', 'Banner Level', 'Name, Version and Service');
- bannerlevel_NameService : FINI.WriteString('General', 'Banner Level', 'Name and Service');
- bannerlevel_Service : FINI.WriteString('General', 'Banner Level', 'Service');
- end;
- // Pop3 Server Settings
- FINI.WriteString('Pop 3 Server', 'Bind Address', FPop3_BindAddress);
- FINI.WriteInteger('Pop 3 Server', 'Listen Port', FPop3_Port);
- FINI.WriteBool('Pop 3 Server', 'Create User On Demand',
- FPop3_CreateUserOnDemand);
- FINI.WriteBool('Pop 3 Server', 'Create User Password On Demand',
- FPop3_CreateUserPasswordOnDemand);
- FINI.WriteInteger('Pop 3 Server', 'Inactivity Timeout (in minutes)',
- FPop3_InactivityTimeout);
- // Smtp Server Settings
- FINI.WriteString('Smtp Server', 'Bind Address', FSmtp_BindAddress);
- FINI.WriteInteger('Smtp Server', 'Listen Port', FSmtp_Port);
- FINI.EraseSection('Smtp Server Domains');
- for x := 0 to FSmtp_Domains.Count -1 do
- FINI.WriteString('Smtp Server Domains', IntToStr(x), FSmtp_Domains[x]);
- FINI.WriteInteger('Smtp Server', 'Inactivity Timeout (in minutes)',
- FSmtp_InactivityTimeout);
- // SMTP Server Access
- FINI.EraseSection('Smtp Server Access - Accepted Domains');
- for x := 0 to FSmtp_Access_AcceptedDomains.Count -1 do
- FINI.WriteString('Smtp Server Access - Accepted Domains', IntToStr(x),
- FSmtp_Access_AcceptedDomains[x]);
- FINI.EraseSection('Smtp Server Access - Banned Mailboxes');
- for x := 0 to FSmtp_Access_BannedMailBoxes.Count -1 do
- FINI.WriteString('Smtp Server Access - Banned Mailboxes', IntToStr(x),
- FSmtp_Access_BannedMailBoxes[x]);
- FINI.EraseSection('Smtp Server Access - Banned Domains');
- for x := 0 to FSmtp_Access_BannedDomains.Count -1 do
- FINI.WriteString('Smtp Server Access - Banned Domains', IntToStr(x),
- FSmtp_Access_BannedDomains[x]);
- FINI.EraseSection('Smtp Server Access - Banned Addresses');
- for x := 0 to FSmtp_Access_BannedAddresses.Count -1 do
- FINI.WriteString('Smtp Server Access - Banned Addresses', IntToStr(x),
- FSmtp_Access_BannedAddresses[x]);
- FINI.WriteBool('Smtp Server Access Control', 'Ban Domains',
- FSmtp_Access_BanDomains);
- FINI.WriteBool('Smtp Server Access Control', 'Ban Addresses',
- FSmtp_Access_BanAddresses);
- FINI.WriteBool('Smtp Server Access Control', 'Ban Mailboxes',
- FSmtp_Access_BanMailboxes);
- // FINI.WriteBool('Smtp Server Access Control', 'Accepted Domains',
- // FSmtp_Access_AcceptAcceptableDomains);
- // FINI.WriteBool('Smtp Server Access Control', 'Local Domains Only',
- // FSmtp_Access_AcceptFromLocalDomains);
- // FINI.WriteBool('Smtp Server Access Control', 'Local Mailboxes Only',
- // FSmtp_Access_AcceptFromLocalUsers);
- // FINI.WriteBool('Smtp Server Access Control', 'For Local Mailboxes Only',
- // FSmtp_Access_OnlyForLocalUsers);
- FINI.WriteBool('Smtp Server Access Control', 'Apply To Maximum',
- FSmtp_Access_OnlyForUnderXUsers);
- FINI.WriteInteger('Smtp Server Access Control', 'To Maximum',
- FSmtp_Access_OnlyForUsersCount);
- FINI.WriteBool('Smtp Server Access Control', 'Restrict',
- FSmtp_Access_Restricted);
- // FINI.WriteBool('Smtp Server', 'Forward Mail', FSmtp_Forward);
- FINI.WriteInteger('Smtp Server', 'Forward Retries', FSmtp_Retries);
- // Agent information
- FINI.WriteInteger('Smtp Agent', 'Polling Interval (in seconds)',
- FAgent_PollingInterval);
- FINI.WriteBool('Smtp Agent', 'Fire Queue Immediately',
- FAgent_ServiceQueueImmediately);
- FINI.WriteBool('Smtp Agent', 'Forward to Master SMTP Server',
- FAgent_ForwardToMasterSMTP);
- FINI.WriteString('Smtp Agent', 'Master SMTP Server',
- FAgent_MasterServerIPAddress);
- FINI.WriteInteger('Smtp Agent', 'Inactivity Timeout (in minutes)',
- FAgent_InactivityTimeout);
- for x := 0 to FUser_Aliases.Count -1 do
- FINI.WriteString('User EMail Aliases', IntToStr(x), FUser_Aliases[x]);
- finally
- FINI.Free;
- end;
- Result := True;
- except
- on E: Exception do Result := False;
- end;
- end;
- procedure TServerInformation.User_GetList(Strings : TStrings);
- var
- SearchRec: TSearchRec;
- SearchResult : Longint;
- begin
- if Assigned(Strings) then begin
- Strings.Clear;
- if DirectoryExists(FMailboxPath) then begin
- SearchResult := FindFirst(FMailboxPath + '*.*', faDirectory, SearchRec);
- while SearchResult = 0 do begin
- if (SearchRec.Name <> '.') and
- (SearchRec.Name <> '..') and
- (SearchRec.Name <> '') and
- (UpperCase(ExtractFileExt(SearchRec.Name)) <> '.INI') {User INI file}
- then begin
- Strings.Add(LowerCase(SearchRec.Name));
- end;
- SearchResult := FindNext(SearchRec);
- end;
- FindClose(SearchRec);
- end;
- end;
- end;
- function TServerInformation.User_Exists(UserName : String) : Boolean;
- begin
- Result := DirectoryExists(FMailboxPath + UserName + '');
- end;
- function TServerInformation.User_Create(UserName : String) : Boolean;
- var
- UserInfo : TPop3UserInformation;
- begin
- Result := True;
- if not User_Exists(UserName) then begin
- UserInfo := TPop3UserInformation.Create;
- Result := UserInfo.SaveToFile(UserName);
- UserInfo.Free;
- end;
- end;
- function TServerInformation.User_Delete(UserName : String) : Boolean;
- var
- x : Integer;
- SearchRec: TSearchRec;
- SearchResult : Longint;
- SL : TStringList;
- OK : Boolean;
- AliasID, AliasUser : String;
- begin
- OK := True;
- // Delete all files in the User Folder and delete the folder
- // Get list of files to delete
- SL := TStringList.Create;
- SearchResult := FindFirst(FMailboxPath + UserName + '*.*',
- faAnyFile, SearchRec);
- while SearchResult = 0 do begin
- if (SearchRec.Name <> '.') and
- (SearchRec.Name <> '..') and
- (SearchRec.Name <> '') then SL.Add(SearchRec.Name);
- SearchResult := FindNext(SearchRec);
- end;
- FindClose(SearchRec);
- // Delete individual files
- for x := 0 to SL.Count -1 do begin
- if FileExists(FMailboxPath + UserName + '' + SL[x]) then
- if not FileOperation(FMailboxPath + UserName + '' + SL[x], '', 'DELETE')
- then OK := False;
- end;
- // Delete folder
- if DirectoryExists(FMailboxPath + UserName) then
- if not FileOperation(FMailboxPath + UserName, '', 'DELETE') then
- OK := False;
- // Delete any aliases
- for x := FUser_Aliases.Count -1 downto 0 do begin
- Alias_Parse(FUser_Aliases[x], AliasID, AliasUser);
- if LowerCase(UserName) = LowerCase(AliasUser) then FUser_Aliases.Delete(x);
- // or FUser_Aliases[x] := AliasID + ALIASSEPERATOR; // remove User ID?
- end;
- Result := OK;
- end;
- function TServerInformation.User_Rename(OldUserName,
- NewUserName : String) : Boolean;
- var
- OK : Boolean;
- x : Longint;
- AliasID, AliasUser : String;
- begin
- OK := True;
- if LowerCase(NewUserName) <> LowerCase(OldUserName) then begin
- if User_Exists(NewUserName) then OK := False;
- if List_Exists(NewUserName) then OK := False;
- if Alias_Exists(NewUserName) then OK := False;
- if not IsNameValid(NewUserName) then OK := False;
- if OK then begin
- // Rename folder
- if not FileOperation(FMailboxPath + OldUserName,
- FMailboxPath + NewUserName, 'RENAME') then
- OK := False;
- // Rename User INI file
- if not FileOperation(FMailboxPath + NewUserName + '' +
- OldUserName + '.ini',
- FMailboxPath + NewUserName + '' +
- NewUserName + '.ini', 'RENAME') then OK := False;
- // Rename any aliases !
- for x := 0 to FUser_Aliases.Count -1 do begin
- Alias_Parse(FUser_Aliases[x], AliasID, AliasUser);
- if LowerCase(OldUserName) = LowerCase(AliasUser) then
- FUser_Aliases[x] := AliasID + ALIASSEPERATOR + NewUserName;
- end;
- end;
- end;
- Result := OK;
- end;
- procedure TServerInformation.List_GetList(Strings : TStrings);
- var
- SearchRec: TSearchRec;
- SearchResult : Longint;
- begin
- if Assigned(Strings) then begin
- Strings.Clear;
- if DirectoryExists(FMailListPath) then begin
- SearchResult := FindFirst(FMailListPath + '*.*', faAnyFile, SearchRec);
- while SearchResult = 0 do begin
- if (SearchRec.Name <> '.') and
- (SearchRec.Name <> '..') and
- (SearchRec.Name <> '') and
- (UpperCase(ExtractFileExt(SearchRec.Name)) = '.INI') {List INI file}
- then begin
- Strings.Add(LowerCase(Copy(SearchRec.Name, 1,
- Length(SearchRec.Name) -4)));
- end;
- SearchResult := FindNext(SearchRec);
- end;
- FindClose(SearchRec);
- end;
- end;
- end;
- function TServerInformation.List_Exists(ListName : String) : Boolean;
- begin
- Result := FileExists(FMailListPath + ListName + '.ini');
- end;
- function TServerInformation.List_Create(ListName : String) : Boolean;
- var
- ListInfo : TMailListInformation;
- begin
- Result := True;
- if not List_Exists(ListName) then begin
- ListInfo := TMailListInformation.Create;
- Result := ListInfo.SaveToFile(ListName, True);
- ListInfo.Free;
- end;
- end;
- function TServerInformation.List_Delete(ListName : String) : Boolean;
- begin
- Result := False;
- if List_Exists(ListName) then begin
- // Delete List INI file
- if FileExists(FMailListPath + ListName + '.ini') then
- Result := FileOperation(FMailListPath + ListName + '.ini', '', 'DELETE');
- end;
- end;
- function TServerInformation.List_Rename(OldListName,
- NewListName : String) : Boolean;
- var
- OK : Boolean;
- begin
- OK := True;
- if LowerCase(NewListName) <> LowerCase(OldListName) then begin
- if User_Exists(NewListName) then OK := False;
- if List_Exists(NewListName) then OK := False;
- if Alias_Exists(NewListName) then OK := False;
- if not IsNameValid(NewListName) then OK := False;
- if OK then begin
- // Rename List INI file
- OK := FileOperation(FMailListPath + OldListName + '.ini',
- FMailListPath + NewListName + '.ini', 'RENAME');
- end;
- end;
- Result := OK;
- end;
- procedure TServerInformation.Alias_SetList(Strings : TStrings);
- var
- x : Longint;
- begin
- if Assigned(Strings) then begin
- FUser_Aliases.Clear;
- for x := 0 to Strings.Count -1 do FUser_Aliases.Add(Strings[x]);
- end;
- end;
- procedure TServerInformation.Alias_GetList(Strings : TStrings);
- var
- x : Longint;
- begin
- if Assigned(Strings) then begin
- Strings.Clear;
- for x := 0 to FUser_Aliases.Count -1 do Strings.Add(FUser_Aliases[x]);
- end;
- end;
- // AliadID = name
- // Alias = name<==>username
- procedure TServerInformation.Alias_Parse(AliasString : String;
- var AliasID : String;
- var AliasUser : String);
- begin
- AliasID := AliasString;
- AliasUser := '';
- if Pos(ALIASSEPERATOR, AliasString) > 0 then begin
- AliasID := Copy(AliasString, 1, Pos(ALIASSEPERATOR, AliasString) -1);
- AliasUser := Copy(AliasString, Pos(ALIASSEPERATOR, AliasString) +
- Length(ALIASSEPERATOR), Length(AliasString));
- end;
- end;
- function TServerInformation.Alias_Exists(AliasIDorAlias : String) : Boolean;
- var
- x : Longint;
- AliasID, AliasUser : String;
- tempAliasID, tempAliasUser : String;
- Found : Boolean;
- begin
- Alias_Parse(AliasIDorAlias, AliasID, AliasUser);
- x := 0;
- Found := False;
- while (not Found) and (x < FUser_Aliases.Count) do begin
- Alias_Parse(FUser_Aliases[x], tempAliasID, tempAliasUser);
- if LowerCase(AliasID) = LowerCase(tempAliasID) then
- Found := True else Inc(x);
- end;
- Result := Found;
- end;
- function TServerInformation.Alias_Create(AliasID, AliasUser : String) : Boolean;
- begin
- Result := False;
- if not Alias_Exists(AliasID) then begin
- FUser_Aliases.Add(AliasID + ALIASSEPERATOR + AliasUser);
- Result := True;
- end;
- end;
- procedure TServerInformation.Alias_Delete(AliasIDorAlias : String);
- var
- x : Longint;
- AliasID, AliasUser : String;
- tempAliasID, tempAliasUser : String;
- begin
- Alias_Parse(AliasIDorAlias, AliasID, AliasUser);
- for x := FUser_Aliases.Count -1 downto 0 do begin
- Alias_Parse(FUser_Aliases[x], tempAliasID, tempAliasUser);
- if LowerCase(AliasID) = LowerCase(tempAliasID) then FUser_Aliases.Delete(x);
- end;
- end;
- function TServerInformation.Alias_Rename(OldAliasIDorAlias,
- NewAliasID : String) : Boolean;
- var
- x : Longint;
- AliasID, AliasUser : String;
- tempAliasID, tempAliasUser : String;
- OK : Boolean;
- begin
- OK := True;
- if User_Exists(NewAliasID) then OK := False;
- if List_Exists(NewAliasID) then OK := False;
- if Alias_Exists(NewAliasID) then OK := False;
- if not IsNameValid(NewAliasID) then OK := False;
- if OK then begin
- Alias_Parse(OldAliasIDorAlias, AliasID, AliasUser);
- for x := FUser_Aliases.Count -1 downto 0 do begin
- Alias_Parse(FUser_Aliases[x], tempAliasID, tempAliasUser);
- if LowerCase(AliasID) = LowerCase(tempAliasID) then begin
- FUser_Aliases[x] := NewAliasID + ALIASSEPERATOR + tempAliasUser;
- end;
- end;
- end;
- Result := OK;
- end;
- function TServerInformation.Alias_Find(AliasIDorAlias : String) : String;
- var
- x : Longint;
- AliasID, AliasUser : String;
- tempAliasID, tempAliasUser : String;
- Found : Boolean;
- begin
- Result := '';
- Alias_Parse(AliasIDorAlias, AliasID, AliasUser);
- x := 0;
- Found := False;
- while (not Found) and (x < FUser_Aliases.Count) do begin
- Alias_Parse(FUser_Aliases[x], tempAliasID, tempAliasUser);
- if LowerCase(AliasID) = LowerCase(tempAliasID) then
- Found := True else Inc(x);
- end;
- if Found then Result := FUser_Aliases[x];
- end;
- function TServerInformation.Alias_Edit(AliasIDorAlias,
- NewAliasUser : String) : Boolean;
- var
- x : Longint;
- AliasID, AliasUser : String;
- tempAliasID, tempAliasUser : String;
- begin
- Result := False;
- Alias_Parse(AliasIDorAlias, AliasID, AliasUser);
- if Alias_Exists(AliasID) then begin
- for x := FUser_Aliases.Count -1 downto 0 do begin
- Alias_Parse(FUser_Aliases[x], tempAliasID, tempAliasUser);
- if LowerCase(AliasID) = LowerCase(tempAliasID) then begin
- FUser_Aliases[x] := AliasID + ALIASSEPERATOR + NewAliasUser;
- Result := True;
- end;
- end;
- end;
- end;
- (******************************************************************************)
- (* *)
- (* START POP3 User Information Object *)
- (* *)
- (******************************************************************************)
- constructor TPop3UserInformation.Create;
- begin
- inherited Create;
- Initialize;
- end;
- destructor TPop3UserInformation.Destroy;
- begin
- inherited Destroy;
- end;
- procedure TPop3UserInformation.Initialize;
- begin
- FUserName := '';
- FPassword := '';
- FRealName := '';
- FUB_DoNotReportUserExists_SMTP := False;
- end;
- function TPop3UserInformation.LoadFromFile(UserName : String) : Boolean;
- var
- FINI : TINIFile;
- Filename : String;
- begin
- Result := False;
- FUserName := UserName;
- Filename := INI.MailBoxPath + FUserName + '' + FUserName + '.ini';
- if DirectoryExists(INI.MailBoxPath + FUserName + '') and
- FileExists(Filename) then try
- FINI := TINIFile.Create(Filename);
- try
- FPassword := FINI.ReadString('User Information', 'Password', '');
- FForwardToAddress := FINI.ReadString('User Information',
- 'Forward To Address', '');
- FRealName := FINI.ReadString('User Information', 'Real Name', '');
- FUB_DoNotReportUserExists_SMTP := FINI.ReadBool('User Information',
- 'Do not report User Exists (SMTP)',
- False);
- FLimit_MessageToBytes := FINI.ReadInteger('User Information',
- 'Limit Message To Bytes', 0);
- FLimit_MailboxToBytes := FINI.ReadInteger('User Information',
- 'Limit Mailbox To Bytes', 0);
- FLimit_MailboxToMessages := FINI.ReadInteger('User Information',
- 'Limit Mailbox To Messages', 0);
- Result := True;
- finally
- FINI.Free;
- end;
- except
- on E: Exception do Result := False;
- end;
- end;
- function TPop3UserInformation.SaveToFile(UserName : String) : Boolean;
- var
- FINI : TINIFile;
- Filename : String;
- begin
- FUserName := UserName;
- ForceDirectories(INI.MailBoxPath + FUserName + '');
- Filename := INI.MailBoxPath + FUserName + '' + FUserName + '.ini';
- try
- FINI := TINIFile.Create(Filename);
- try
- FINI.WriteString('User Information', 'Password', FPassword);
- FINI.WriteString('User Information', 'Forward To Address',
- FForwardToAddress);
- FINI.WriteString('User Information', 'Real Name', FRealName);
- FINI.WriteBool('User Information', 'Do not report User Exists (SMTP)',
- FUB_DoNotReportUserExists_SMTP);
- FINI.WriteInteger('User Information', 'Limit Message To Bytes',
- FLimit_MessageToBytes);
- FINI.WriteInteger('User Information', 'Limit Mailbox To Bytes',
- FLimit_MailboxToBytes);
- FINI.WriteInteger('User Information', 'Limit Mailbox To Messages',
- FLimit_MailboxToMessages);
- finally
- FINI.Free;
- end;
- Result := True;
- except
- on E: Exception do Result := False;
- end;
- end;
- function TPop3UserInformation.SaveToFile : Boolean;
- var
- FINI : TINIFile;
- Filename : String;
- begin
- ForceDirectories(INI.MailBoxPath + FUserName + '');
- Filename := INI.MailBoxPath + FUserName + '' + UserName + '.ini';
- try
- FINI := TINIFile.Create(Filename);
- try
- FINI.WriteString('User Information', 'Password', FPassword);
- FINI.WriteString('User Information', 'Forward To Address',
- FForwardToAddress);
- FINI.WriteString('User Information', 'Real Name', FRealName);
- FINI.WriteBool('User Information', 'Do not report User Exists (SMTP)',
- FUB_DoNotReportUserExists_SMTP);
- finally
- FINI.Free;
- end;
- Result := True;
- except
- on E: Exception do Result := False;
- end;
- end;
- function TPop3UserInformation.SaveMail(SL : TStringList) : Boolean;
- var
- Filename : String;
- begin
- Result := False;
- if Assigned(SL) then begin
- if not DirectoryExists(INI.MailBoxPath + FUserName + '') then
- ForceDirectories(INI.MailBoxPath + FUserName + '');
- Filename := GetUniqueFilename(INI.MailBoxPath + FUserName + '');
- if Filename <> '' then
- SL.SaveToFile(INI.MailBoxPath + FUserName + '' + Filename + '.txt');
- end;
- end;
- (******************************************************************************)
- (* *)
- (* STOP POP3 User Information Object *)
- (* *)
- (******************************************************************************)
- (******************************************************************************)
- (* *)
- (* START Mail List Information Object *)
- (* *)
- (******************************************************************************)
- constructor TMailListInformation.Create;
- begin
- inherited Create;
- FFileDateTime := 0;
- FMembers := TList.Create;
- FPendingMembers := TList.Create;
- FSL_Welcome := TStringList.Create;
- FSL_Signature := TStringList.Create;
- FSL_Farewell := TStringList.Create;
- Initialize;
- end;
- procedure TMailListInformation.MembersClear;
- var
- x : Longint;
- ListMember : PMailListMemberInfoRec;
- begin
- for x := FMembers.Count -1 downto 0 do begin
- ListMember := FMembers[x];
- FreeMem(ListMember, SizeOf(TMailListMemberInfoRec));
- FMembers.Delete(x);
- end;
- end;
- procedure TMailListInformation.PendingMembersClear;
- var
- x : Longint;
- ListMember : PMailListPendingMemberInfoRec;
- begin
- for x := FPendingMembers.Count -1 downto 0 do begin
- ListMember := FPendingMembers[x];
- FreeMem(ListMember, SizeOf(TMailListPendingMemberInfoRec));
- FPendingMembers.Delete(x);
- end;
- end;
- destructor TMailListInformation.Destroy;
- begin
- PendingMembersClear;
- FPendingMembers.Free;
- MembersClear;
- FMembers.Free;
- FSL_Welcome.Free;
- FSL_Signature.Free;
- FSL_Farewell.Free;
- inherited Destroy;
- end;
- procedure TMailListInformation.Initialize;
- begin
- MembersClear;
- PendingMembersClear;
- FPassword := '';
- FErrorsMailedTo := '';
- FFile_Welcome := '';
- FFile_Signature := '';
- FFile_Farewell := '';
- FSL_Welcome.Clear;
- FSL_Signature.Clear;
- FSL_Farewell.Clear;
- FLB_AllowPublicSubscription := True;
- FLB_ForceRepliesToList := True;
- FLB_DoNotReportListMembers_SMTP := False;
- FLB_DoNotReportListExists := False;
- FLB_DoNotReportListMembers := False;
- FLB_MemberSubmissionOnly := False;
- FArchiveFile := '';
- end;
- function TMailListInformation.GetMembers(Index : Longint)
- : PMailListMemberInfoRec;
- begin
- Result := nil;
- if (Index > -1) and (Index < FMembers.Count) then Result := FMembers[Index];
- end;
- function TMailListInformation.GetPendingMembers(Index : Longint)
- : PMailListPendingMemberInfoRec;
- begin
- Result := nil;
- if (Index > -1) and (Index < FPendingMembers.Count) then
- Result := FPendingMembers[Index];
- end;
- function TMailListInformation.MemberAdd(Active,
- Manager : Boolean;
- EMail : String)
- : PMailListMemberInfoRec;
- var
- ListMember : PMailListMemberInfoRec;
- begin
- Result := nil;
- if EMail <> '' then begin
- GetMem(ListMember, SizeOf(TMailListMemberInfoRec));
- ListMember.Active := Active;
- ListMember.Manager := Manager;
- ListMember.EMail := EMail;
- FMembers.Add(ListMember);
- Result := ListMember;
- end;
- end;
- procedure TMailListInformation.MemberDelete(Index : Longint);
- var
- ListMember : PMailListMemberInfoRec;
- begin
- if (Index > -1) and (Index < FMembers.Count) then begin
- ListMember := FMembers[Index];
- FreeMem(ListMember, SizeOf(TMailListMemberInfoRec));
- FMembers.Delete(Index);
- end;
- end;
- function TMailListInformation.GetMemberCount : Longint;
- begin
- Result := FMembers.Count;
- end;
- function TMailListInformation.PendingMemberAdd(ExpirationDate : TDateTime;
- MagicNumber : Integer;
- EMail : String)
- : PMailListPendingMemberInfoRec;
- var
- ListMember : PMailListPendingMemberInfoRec;
- begin
- Result := nil;
- if EMail <> '' then begin
- GetMem(ListMember, SizeOf(TMailListPendingMemberInfoRec));
- ListMember.ExpirationDate := ExpirationDate;
- ListMember.EMail := EMail;
- ListMember.MagicNumber := MagicNumber;
- FPendingMembers.Add(ListMember);
- Result := ListMember;
- end;
- end;
- procedure TMailListInformation.PendingMemberDelete(Index : Longint);
- var
- ListMember : PMailListPendingMemberInfoRec;
- begin
- if (Index > -1) and (Index < FPendingMembers.Count) then begin
- ListMember := FPendingMembers[Index];
- FreeMem(ListMember, SizeOf(TMailListPendingMemberInfoRec));
- FPendingMembers.Delete(Index);
- end;
- end;
- procedure TMailListInformation.PendingMemberDelete(TargetListMember
- : PMailListPendingMemberInfoRec);
- var
- x : Longint;
- ListMember : PMailListPendingMemberInfoRec;
- begin
- for x := FPendingMembers.Count -1 downto 0 do begin
- ListMember := FPendingMembers[x];
- if ListMember = TargetListMember then PendingMemberDelete(x);
- end;
- end;
- function TMailListInformation.GetPendingMemberCount : Longint;
- begin
- Result := FPendingMembers.Count;
- end;
- function TMailListInformation.PendingMember_FindByMagicNumber(MagicNumber
- : Integer) : PMailListPendingMemberInfoRec;
- var
- x : Longint;
- Found : Boolean;
- ListMember : PMailListPendingMemberInfoRec;
- begin
- Result := nil;
- Found := False;
- x := 0;
- while (not Found) and (x < FPendingMembers.Count) do begin
- ListMember := FPendingMembers[x];
- if ListMember.MagicNumber = MagicNumber then begin
- Found := True;
- Result := ListMember;
- end else Inc(x);
- end;
- end;
- function TMailListInformation.PendingMember_NewMagicNumber : Integer;
- var
- x : Longint;
- Match : Boolean;
- ListMember : PMailListPendingMemberInfoRec;
- MagicNumber : Integer;
- begin
- MagicNumber := 0;
- Match := True;
- while Match do begin
- MagicNumber := Random(10000);
- Match := False;
- for x := FPendingMembers.Count -1 downto 0 do begin
- ListMember := FPendingMembers[x];
- if ListMember.MagicNumber = MagicNumber then Match := True;
- end;
- end;
- Result := MagicNumber;
- end;
- procedure TMailListInformation.SetSL_Welcome(Strings : TStrings);
- var
- x : Longint;
- begin
- if Assigned(Strings) then begin
- FSL_Welcome.Clear;
- for x := 0 to Strings.Count -1 do FSL_Welcome.Add(Strings[x]);
- end;
- end;
- procedure TMailListInformation.SetSL_Signature(Strings : TStrings);
- var
- x : Longint;
- begin
- if Assigned(Strings) then begin
- FSL_Signature.Clear;
- for x := 0 to Strings.Count -1 do FSL_Signature.Add(Strings[x]);
- end;
- end;
- procedure TMailListInformation.SetSL_Farewell(Strings : TStrings);
- var
- x : Longint;
- begin
- if Assigned(Strings) then begin
- FSL_Farewell.Clear;
- for x := 0 to Strings.Count -1 do FSL_Farewell.Add(Strings[x]);
- end;
- end;
- function TMailListInformation.LoadFromFile(ListName : String) : Boolean;
- var
- FINI : TINIFile;
- Filename : String;
- x : Longint;
- SL : TStringList;
- tempStr, MemberStr : String;
- ListMember : PMailListMemberInfoRec;
- Active, Manager : Boolean;
- PendingListMember : PMailListPendingMemberInfoRec;
- ExpirationDate : TDateTime;
- MagicNumber : Integer;
- Address : String;
- begin
- Result := False;
- Filename := INI.MailListPath + ListName + '.ini';
- Initialize;
- try
- FINI := TINIFile.Create(Filename);
- try
- SL := TStringList.Create;
- FINI.ReadSectionValues('Members', SL);
- // Clean out "x="
- for x := 0 to SL.Count -1 do begin
- MemberStr := SL[x];
- if Pos('=', MemberStr) > 0 then
- MemberStr := Copy(MemberStr, Pos('=', MemberStr) +1,
- Length(MemberStr));
- if Pos(';', MemberStr) > 0 then begin
- tempStr := Copy(MemberStr, 1, Pos(';', MemberStr) -1);
- Active := not (UpperCase(tempStr) = 'INACTIVE');
- MemberStr := Copy(MemberStr, Pos(';', MemberStr) +1,
- Length(MemberStr));
- if Pos(';', MemberStr) > 0 then begin
- tempStr := Copy(MemberStr, 1, Pos(';', MemberStr) -1);
- Manager := not (UpperCase(tempStr) = 'NOMANAGER');
- Address := Copy(MemberStr, Pos(';', MemberStr) +1,
- Length(MemberStr));
- if Address <> '' then begin
- GetMem(ListMember, SizeOf(TMailListMemberInfoRec));
- ListMember.Active := Active;
- ListMember.Hidden := False; // not implemented yet
- ListMember.Manager := Manager;
- ListMember.EMail := Address;
- FMembers.Add(ListMember);
- end;
- end;
- end;
- end;
- SL.Free;
- SL := TStringList.Create;
- FINI.ReadSectionValues('Pending Members', SL);
- // Clean out "x="
- for x := 0 to SL.Count -1 do begin
- MemberStr := SL[x];
- if Pos('=', MemberStr) > 0 then
- MemberStr := Copy(MemberStr, Pos('=', MemberStr) +1,
- Length(MemberStr));
- if Pos(';', MemberStr) > 0 then begin
- tempStr := Copy(MemberStr, 1, Pos(';', MemberStr) -1);
- try
- ExpirationDate := StrToFloat(tempStr);
- except
- on E: Exception do ExpirationDate := Now;
- end;
- MemberStr := Copy(MemberStr, Pos(';', MemberStr) +1,
- Length(MemberStr));
- if Pos(';', MemberStr) > 0 then begin
- tempStr := Copy(MemberStr, 1, Pos(';', MemberStr) -1);
- try
- MagicNumber := StrToInt(tempStr);
- except
- on E: Exception do MagicNumber := -1;
- end;
- Address := Trim(Copy(MemberStr, Pos(';', MemberStr) +1,
- Length(MemberStr)));
- if Address <> '' then begin
- GetMem(PendingListMember, SizeOf(TMailListPendingMemberInfoRec));
- PendingListMember.ExpirationDate := ExpirationDate;
- PendingListMember.MagicNumber := MagicNumber;
- PendingListMember.EMail := Address;
- FPendingMembers.Add(PendingListMember);
- end;
- end;
- end;
- end;
- SL.Free;
- FINI.ReadSectionValues('Welcome Message', FSL_Welcome);
- for x := 0 to FSL_Welcome.Count -1 do begin // Clean out "x="
- if Pos('=', FSL_Welcome[x]) > 0 then
- FSL_Welcome[x] := Copy(FSL_Welcome[x], Pos('=', FSL_Welcome[x]) +1,
- Length(FSL_Welcome[x]));
- if FSL_Welcome[x] = '<This line intentionally left blank.>' then
- FSL_Welcome[x] := '';
- end;
- FINI.ReadSectionValues('Signature Message', FSL_Signature);
- for x := 0 to FSL_Signature.Count -1 do begin // Clean out "x="
- if Pos('=', FSL_Signature[x]) > 0 then
- FSL_Signature[x] := Copy(FSL_Signature[x],
- Pos('=', FSL_Signature[x]) +1,
- Length(FSL_Signature[x]));
- if FSL_Signature[x] = '<This line intentionally left blank.>' then
- FSL_Signature[x] := '';
- end;
- FINI.ReadSectionValues('Farewell Message', FSL_Farewell);
- for x := 0 to FSL_Farewell.Count -1 do begin // Clean out "x="
- if Pos('=', FSL_Farewell[x]) > 0 then
- FSL_Farewell[x] := Copy(FSL_Farewell[x],
- Pos('=', FSL_Farewell[x]) +1,
- Length(FSL_Farewell[x]));
- if FSL_Farewell[x] = '<This line intentionally left blank.>' then
- FSL_Farewell[x] := '';
- end;
- FPassword := FINI.ReadString('Security', 'Password', '');
- FErrorsMailedTo := FINI.ReadString('General', 'Mail Errors To', '');
- FFile_Welcome := FINI.ReadString('Auto Files', 'Welcome', '');
- FFile_Signature := FINI.ReadString('Auto Files', 'Signature', '');
- FFile_Farewell := FINI.ReadString('Auto Files', 'Farewell', '');
- FLB_AllowPublicSubscription
- := FINI.ReadBool('List Behavior', 'Allow Open (Public) Subscription',
- True);
- FLB_ForceRepliesToList
- := FINI.ReadBool('List Behavior', 'Force Replies to List', True);
- FLB_DoNotReportListMembers_SMTP
- := FINI.ReadBool('List Behavior', 'Do not report List Members to SMTP',
- False);
- FLB_DoNotReportListExists
- := FINI.ReadBool('List Behavior', 'Do not report List Exists', False);
- FLB_DoNotReportListMembers
- := FINI.ReadBool('List Behavior', 'Do not report List Members', False);
- FLB_MemberSubmissionOnly
- := FINI.ReadBool('List Behavior', 'Member-Only Submission', False);
- FArchiveFile := FINI.ReadString('Digest', 'Filename', '');
- Result := True;
- x := FileAge(Filename);
- if x <> -1 then FFileDateTime := x;
- finally
- FINI.Free;
- end;
- except
- on E: Exception do Result := False;
- end;
- end;
- function TMailListInformation.SaveToFile(ListName : String;
- Force : Boolean) : Boolean;
- var
- FINI : TINIFile;
- Filename : String;
- x : Longint;
- tempStr : String;
- ListMember : PMailListMemberInfoRec;
- PendingListMember : PMailListPendingMemberInfoRec;
- OK : Boolean;
- begin
- Result := False;
- OK := False;
- Filename := INI.MailListPath + ListName + '.ini';
- x := FileAge(Filename);
- if (x <> -1) and (FFileDateTime = x) then OK := True;
- if (x <> -1) and (FFileDateTime <> x) and (Force) then OK := True;
- if (x = -1) then OK := True;
- if OK then
- try
- FINI := TINIFile.Create(Filename);
- try
- FINI.EraseSection('Members');
- for x := 0 to FMembers.Count -1 do begin
- ListMember := FMembers[x];
- if ListMember.Active then tempStr := 'ACTIVE;'
- else tempStr := 'INACTIVE;';
- if ListMember.Manager then tempStr := tempStr + 'MANAGER;'
- else tempStr := tempStr + 'NOMANAGER;';
- FINI.WriteString('Members', IntToStr(x), tempStr + ListMember.EMail);
- end;
- FINI.EraseSection('Pending Members');
- for x := 0 to FPendingMembers.Count -1 do begin
- PendingListMember := FPendingMembers[x];
- tempStr := FloatToStr(PendingListMember.ExpirationDate) + ';';
- tempStr := tempStr + IntToStr(PendingListMember.MagicNumber) + ';';
- FINI.WriteString('Pending Members', IntToStr(x),
- tempStr + PendingListMember.EMail);
- end;
- FINI.EraseSection('Welcome Message');
- for x := 0 to FSL_Welcome.Count -1 do
- if Trim(FSL_Welcome[x]) = '' then
- FINI.WriteString('Welcome Message', IntToStr(x),
- '<This line intentionally left blank.>')
- else
- FINI.WriteString('Welcome Message', IntToStr(x), FSL_Welcome[x]);
- FINI.EraseSection('Signature Message');
- for x := 0 to FSL_Signature.Count -1 do
- if Trim(FSL_Signature[x]) = '' then
- FINI.WriteString('Signature Message', IntToStr(x),
- '<This line intentionally left blank.>')
- else
- FINI.WriteString('Signature Message', IntToStr(x), FSL_Signature[x]);
- FINI.EraseSection('Farewell Message');
- for x := 0 to FSL_Farewell.Count -1 do
- if Trim(FSL_Farewell[x]) = '' then
- FINI.WriteString('Farewell Message', IntToStr(x),
- '<This line intentionally left blank.>')
- else
- FINI.WriteString('Farewell Message', IntToStr(x), FSL_Farewell[x]);
- FINI.WriteString('Security', 'Password', FPassword);
- FINI.WriteString('General', 'Mail Errors To', FErrorsMailedTo);
- FINI.WriteString('Auto Files', 'Welcome', FFile_Welcome);
- FINI.WriteString('Auto Files', 'Signature', FFile_Signature);
- FINI.WriteString('Auto Files', 'Farewell', FFile_Farewell);
- FINI.WriteBool('List Behavior', 'Allow Open (Public) Subscription',
- FLB_AllowPublicSubscription);
- FINI.WriteBool('List Behavior', 'Force Replies to List',
- FLB_ForceRepliesToList);
- FINI.WriteBool('List Behavior', 'Do not report List Members to SMTP',
- FLB_DoNotReportListMembers_SMTP);
- FINI.WriteBool('List Behavior', 'Do not report List Exists',
- FLB_DoNotReportListExists);
- FINI.WriteBool('List Behavior', 'Do not report List Members',
- FLB_DoNotReportListMembers);
- FINI.WriteBool('List Behavior', 'Member-Only Submission',
- FLB_MemberSubmissionOnly);
- FINI.WriteString('Digest', 'Filename', FArchiveFile);
- finally
- FINI.Free;
- end;
- Result := True;
- except
- on E: Exception do Result := False;
- end;
- end;
- (******************************************************************************)
- (* *)
- (* STOP Mail List Information Object *)
- (* *)
- (******************************************************************************)
- (******************************************************************************)
- (* *)
- (* START POP3 User Mail Information Object *)
- (* *)
- (******************************************************************************)
- constructor TPop3MailInformation.Create;
- begin
- inherited Create;
- FMail := TList.Create;
- FFolderPath := '';
- end;
- procedure TPop3MailInformation.DropAllMail;
- var
- x : Longint;
- MailItem : PPop3MailEntry;
- begin
- for x := FMail.Count -1 downto 0 do begin
- MailItem := FMail[x];
- FreeMem(MailItem, SizeOf(TPop3MailEntry));
- FMail.Delete(x);
- end;
- end;
- destructor TPop3MailInformation.Destroy;
- begin
- DropAllMail;
- FMail.Free;
- inherited Destroy;
- end;
- function TPop3MailInformation.GetCount : Longint;
- begin
- Result := FMail.Count;
- end;
- function TPop3MailInformation.GetDeletedCount : Longint;
- var
- x, Total : Longint;
- MailItem : PPop3MailEntry;
- begin
- Total := 0;
- for x := 0 to FMail.Count -1 do begin
- MailItem := FMail[x];
- if MailItem.MarkForDelete then Inc(Total);
- end;
- Result := Total;
- end;
- function TPop3MailInformation.GetByteCount : Longint;
- var
- x, Total : Longint;
- MailItem : PPop3MailEntry;
- begin
- Total := 0;
- for x := 0 to FMail.Count -1 do begin
- MailItem := FMail[x];
- Total := Total + MailItem.FileSize;
- end;
- Result := Total;
- end;
- function TPop3MailInformation.GetMailEntry(Index: Integer) : PPop3MailEntry;
- begin
- Result := nil;
- if (Index > -1) and (Index < FMail.Count) then Result := FMail[Index];
- end;
- procedure TPop3MailInformation.ReadFolder(UserName : String);
- var
- FolderPath : String;
- SearchRec: TSearchRec;
- SearchResult : Longint;
- Count : Longint;
- MailItem : PPop3MailEntry;
- begin
- FolderPath := INI.MailBoxPath + UserName + '';
- if DirectoryExists(FolderPath) then begin
- FFolderPath := FolderPath;
- DropAllMail;
- Count := 0;
- SearchResult := FindFirst(FolderPath + '*.*', faAnyFile, SearchRec);
- while SearchResult = 0 do begin
- if (SearchRec.Name <> '.') and
- (SearchRec.Name <> '..') and
- (SearchRec.Name <> '') and
- (UpperCase(ExtractFileExt(SearchRec.Name)) <> '.INI') and
- (not (SearchRec.Attr and faDirectory > 0)) then begin
- Inc(Count);
- GetMem(MailItem, SizeOf(TPop3MailEntry));
- MailItem.Number := Count;
- MailItem.Filename := SearchRec.Name;
- MailItem.FileSize := GetFileSize(FolderPath + SearchRec.Name);
- MailItem.MarkForDelete := False;
- FMail.Add(MailItem);
- end;
- SearchResult := FindNext(SearchRec);
- end;
- FindClose(SearchRec);
- end;
- end;
- function TPop3MailInformation.Find(ID : Integer) : PPop3MailEntry;
- var
- x : Longint;
- MailItem : PPop3MailEntry;
- begin
- Result := nil;
- for x := 0 to FMail.Count -1 do begin
- MailItem := FMail[x];
- if MailItem.Number = ID then Result := FMail[x];
- end;
- end;
- function TPop3MailInformation.DeleteMarkedMessages : Longint;
- // Return delete count
- var
- x, Count : Longint;
- FileLocation : String;
- MailItem : PPop3MailEntry;
- begin
- Count := 0;
- for x := 0 to FMail.Count -1 do begin
- MailItem := FMail[x];
- if MailItem.MarkForDelete then begin
- FileLocation := FFolderPath + MailItem.Filename;
- if FileExists(FileLocation) and
- FileOperation(FileLocation, '', 'DELETE') then Inc(Count);
- end;
- end;
- Result := Count;
- end;
- (******************************************************************************)
- (* *)
- (* STOP POP3 User Mail Information Object *)
- (* *)
- (******************************************************************************)
- (******************************************************************************)
- (* *)
- (* START Message Route Object *)
- (* *)
- (******************************************************************************)
- constructor TMessageRouteInformation.Create(Kind
- : TMessageRouteInformation_Kind);
- begin
- inherited Create;
- FKind := Kind;
- FHosts := TStringList.Create;
- Initialize;
- end;
- destructor TMessageRouteInformation.Destroy;
- begin
- FHosts.Free;
- inherited Destroy;
- end;
- procedure TMessageRouteInformation.Initialize;
- begin
- FHosts.Clear;
- FMailbox := '';
- FDomain := '';
- end;
- function TMessageRouteInformation.ParseRoute(Route : String) : Integer;
- // Given a route... populate the internal data structures
- // Return Codes:
- // 0 = Parsed correctly.
- // 1 = route was empty
- // 2 = mismatched brackets <>
- // 3 = mismatched host brackets []
- // 4 = host name didn't start with @
- // 5 = no @ in mailbox specification
- // 6 = bad mailbox quoting ""
- var
- Error : Integer;
- LeftBracket, RightBracket : Integer;
- RouteContents : String;
- HostList, HostStr : String;
- BoxandDomain, Mailbox, Domain : String;
- begin
- // Format:
- // <@HostA,@[1.2.3.4],@#456:"Mail Box"@Domain>
- // Return of 0 indicates success...
- // any other number is a failure of some kind...
- Error := 0;
- FHosts.CLear;
- FDomain := '';
- FMailbox := '';
- // may accept non <> bracketed routes!
- LeftBracket := Pos('<', Route);
- RightBracket := Pos('>', Route);
- if ((LeftBracket = 0) and (RightBracket = 0)) or
- ((LeftBracket > 0) and (RightBracket > 0)) then begin
- // Fetch Real Route (no brackets)
- if LeftBracket = 0 then RouteContents := Trim(Route)
- else begin
- RouteContents := Trim(Copy(Route, Pos('<', Route) +1, Length(Route)));
- RouteContents := Trim(Copy(RouteContents, 1,
- Pos('>', RouteContents) -1));
- end;
- if RouteContents = '' then begin
- Error := 1;
- end else begin
- // Seperate out hosts
- if Pos(':', RouteContents) > 0 then begin
- // There are hosts and a Mailbox at a domain...
- BoxandDomain := Trim(Copy(RouteContents, Pos(':', RouteContents) +1,
- Length(RouteContents)));
- // This part is the mailbox and domain
- HostList := Trim(Copy(RouteContents, 1, Pos(':', RouteContents) -1));
- // This part is the comma seperated host list
- // If we add a comma to the end, we can process while there are commas
- // cute idea, huh?
- HostList := HostList + ',';
- while Pos(',', HostList) > 0 do begin
- HostStr := Trim(Copy(HostList, 1, Pos(',', HostList) -1));
- HostList := Trim(Copy(HostList, Pos(',', HostList) +1,
- Length(HostList)));
- // must strip @ off...
- if Pos('@', HostStr) = 1 then begin
- HostStr := Trim(Copy(HostStr, 2, Length(HostStr)));
- if Copy(HostStr, 1, 1) = '#' then begin
- // The host is specified as a machine number...
- // when does this happen on the internet?
- HostStr := Trim(Copy(HostStr, 2, Length(HostStr)));
- end else
- if (Pos('[', HostStr) > 0) or (Pos(']', HostStr) > 0) then begin
- // The host is specified as a dotted IP address that we do not
- // desolve... we just contact directly. Woo-hoo!
- if Copy(HostStr, 1, 1) = '[' then begin
- if Copy(HostStr, Length(HostStr), 1) = ']' then begin
- // Here's our host Domain name
- HostStr := Trim(Copy(HostStr, 2, Length(HostStr) -2));
- end else begin
- // This could be right... but we have a host bracket problem
- HostStr := Trim(Copy(HostStr, 2, Length(HostStr) -1));
- Error := 3; // bad host bracketing
- end;
- end else begin
- // We have a host bracket problem
- Error := 3;
- end;
- end;
- if HostStr <> '' then FHosts.Add(HostStr);
- end else Error := 4; // Host name doesn't start with an @
- end;
- end else BoxandDomain := RouteContents;
- // Find Domain and mailbox
- if Pos('@', BoxandDomain) > 0 then begin
- Mailbox := Trim(Copy(BoxandDomain, 1, Pos('@', BoxandDomain) -1));
- Domain := Trim(Copy(BoxandDomain, Pos('@', BoxandDomain) +1,
- Length(BoxandDomain)));
- // Mailbox first
- if Pos('"', Mailbox) > 0 then begin
- if Copy(Mailbox, 1, 1) = '"' then begin
- if Copy(Mailbox, Length(Mailbox), 1) = '"' then begin
- Mailbox := Trim(Copy(Mailbox, 2, Length(Mailbox) -2));
- end else begin
- Mailbox := Trim(Copy(Mailbox, 2, Length(Mailbox) -1));
- Error := 6; // bad mailbox quoting
- end;
- FMailbox := Mailbox;
- end else begin
- Error := 6; // bad mailbox quoting
- end;
- end else begin
- FMailbox := Mailbox;
- end;
- // Domain
- HostStr := Domain;
- if Copy(HostStr, 1, 1) = '#' then begin
- // The host is specified as a machine number...
- // when does this happen on the internet?
- HostStr := Trim(Copy(HostStr, 2, Length(HostStr)));
- end else
- if (Pos('[', HostStr) > 0) or (Pos(']', HostStr) > 0) then begin
- // The host is specified as a dotted IP address that we do not
- // desolve... we just contact directly. Woo-hoo!
- if Copy(HostStr, 1, 1) = '[' then begin
- if Copy(HostStr, Length(HostStr), 1) = ']' then begin
- // Here's our host Domain name
- HostStr := Trim(Copy(HostStr, 2, Length(HostStr) -2));
- end else begin
- // This could be right... but we have a host bracket problem
- HostStr := Trim(Copy(HostStr, 2, Length(HostStr) -1));
- Error := 3; // bad host bracketing
- end;
- end else begin
- // We have a host bracket problem
- Error := 3;
- end;
- end;
- FDomain := HostStr;
- end else begin
- // Mailbox wasn't seperated from domain by @
- Error := 5; // no mailbox (x@y)
- end;
- end;
- end else begin
- // the route had mis-matched <> brackets
- Error := 2;
- end;
- Result := Error;
- end;
- function TMessageRouteInformation.BuildRoute : String;
- // Construct a route from the internal data structures
- var
- x : Longint;
- tempStr, HostStr : String;
- begin
- tempStr := '<';
- // Hosts
- for x := 0 to FHosts.Count -1 do begin
- HostStr := FormatedAtDomain(FHosts[x]);
- if HostStr <> '' then
- if x < FHosts.Count -1 then tempStr := tempStr + HostStr + ','
- else tempStr := tempStr + HostStr + ':'
- end;
- // Mailbox and Domain
- if (FMailbox <> '') and (FDomain <> '') then
- tempStr := tempStr + FormatedAddress(FMailbox, FDomain);
- tempStr := tempStr + '>';
- Result := tempStr;
- end;
- (******************************************************************************)
- (* *)
- (* STOP Message Route Object *)
- (* *)
- (******************************************************************************)
- (******************************************************************************)
- (* *)
- (* START Window Handle Component Object *)
- (* *)
- (* This Object is just a TComponent but with a Window Handle so we can post *)
- (* Windows Messages to it. It fires an event for ALL Windows Messages so we *)
- (* can see what we were sent. The Windows Handle code is lifted straight *)
- (* from Francois' code to generate a handle for the TWSocket component *)
- (* *)
- (******************************************************************************)
- // This stuff is necessary to register a windows class and create a window
- // all so I can have a windows handle for getting a message!
- function WHComponentWindowProc(hWindow : HWND; aMessage : Integer;
- wParam : WPARAM; lParam : LPARAM)
- : Integer; stdcall;
- var
- Obj : TWHComponent;
- MsgRec : TMessage;
- begin
- { GetWindowLong is retrieving info we asked it to store with SetWindowLong }
- { in the WindowClass.cbWndExtra when we registered. We stored the Object }
- { ID for the object. That way, we could fetch it here and use it for }
- { windows message handling! }
- Obj := TWHComponent(GetWindowLong(hWindow, 0));
- if not Assigned(Obj) then begin
- Result := DefWindowProc(hWindow, aMessage, wParam, lParam);
- end else begin
- { Delphi use a TMessage type to pass paramter to his own kind of }
- { windows procedure. So we are doing the same... }
- if aMessage <> 0 then begin
- MsgRec.Msg := aMessage;
- MsgRec.wParam := wParam;
- MsgRec.lParam := lParam;
- Obj.WinProc(MsgRec);
- Result := MsgRec.Result;
- end;
- end;
- end;
- function TWHComponent.GetWindowHandle(Obj : TObject) : HWnd;
- const
- ComponentName = 'WHComponentWindowClass';
- var
- WindowClass : TWndClass;
- begin
- // can't re-register a class, so you gotta check if it's already registered!
- if not GetClassInfo(HInstance, ComponentName, WindowClass) then begin
- WindowClass.Style := 0;
- WindowClass.lpfnWndProc := @WHComponentWindowProc;
- WindowClass.cbClsExtra := 0;
- WindowClass.cbWndExtra := SizeOf(Pointer);
- { This is where we'll store a reference to the created object }
- WindowClass.hInstance := HInstance;
- WindowClass.hIcon := 0;
- WindowClass.hCursor := 0;
- WindowClass.hbrBackground := 0;
- WindowClass.lpszMenuName := nil;
- WindowClass.lpszClassName := ComponentName;
- if Windows.RegisterClass(WindowClass) <> 0 then
- Result := CreateWindowEx(WS_EX_TOOLWINDOW,
- ComponentName,
- '', {window name}
- WS_POPUP, {window style}
- 0, 0, {X, Y}
- 0, 0, {Width, Height}
- 0, {hWndParent}
- 0, {hMenu}
- HInstance,{hInstance}
- nil) {CreateParam}
- else Result := 0;
- if Result <> 0 then SetWindowLong(Result, 0, Integer(Obj));
- { Here we actually store the new object's handle...}
- { Necessary for handling of the windows messages }
- end else begin
- Result := CreateWindowEx(WS_EX_TOOLWINDOW,
- ComponentName,
- '', {window name}
- WS_POPUP, {window style}
- 0, 0, {X, Y}
- 0, 0, {Width, Height}
- 0, {hWndParent}
- 0, {hMenu}
- HInstance,{hInstance}
- nil); {CreateParam}
- if Result <> 0 then SetWindowLong(Result, 0, Integer(Obj));
- { Here we actually store the new object's handle...}
- { Necessary for handling of the windows messages }
- end;
- end;
- procedure TWHComponent.WinProc(var Msg: TMessage);
- begin
- if Assigned(FWindowsMessage) then OnWindowsMessage(Self, Msg);
- end;
- constructor TWHComponent.Create(AOwner: TComponent);
- var
- x : integer;
- begin
- inherited Create(AOwner); // Get our Window Handle
- FHandle := GetWindowHandle(Self);
- if FHandle = 0 then begin
- // Error getting handle... InttoStr(GetLastError)
- end;
- end;
- destructor TWHComponent.Destroy;
- begin
- DestroyWindow(FHandle); // destroy our Window Handle
- inherited destroy;
- end;
- (******************************************************************************)
- (* *)
- (* STOP Window Handle Component Object *)
- (* *)
- (******************************************************************************)
- function IsNameValid(Name : String) : Boolean;
- // Is a User, List or Alias name valid?
- begin
- Result := True;
- if Pos('(', Name) > 0 then Result := False;
- if Pos(')', Name) > 0 then Result := False;
- if Pos('<', Name) > 0 then Result := False;
- if Pos('>', Name) > 0 then Result := False;
- if Pos('@', Name) > 0 then Result := False;
- if Pos(',', Name) > 0 then Result := False;
- if Pos(';', Name) > 0 then Result := False;
- if Pos(':', Name) > 0 then Result := False;
- if Pos('', Name) > 0 then Result := False;
- if Pos('"', Name) > 0 then Result := False;
- if Pos('[', Name) > 0 then Result := False;
- if Pos(']', Name) > 0 then Result := False;
- end;
- function IsNameValidIncludingAt(Name : String) : Boolean;
- // Just for Aliases that can include FQ mailboxes...
- begin
- Result := True;
- if Pos('(', Name) > 0 then Result := False;
- if Pos(')', Name) > 0 then Result := False;
- if Pos('<', Name) > 0 then Result := False;
- if Pos('>', Name) > 0 then Result := False;
- if Pos(',', Name) > 0 then Result := False;
- if Pos(';', Name) > 0 then Result := False;
- if Pos(':', Name) > 0 then Result := False;
- if Pos('', Name) > 0 then Result := False;
- if Pos('"', Name) > 0 then Result := False;
- if Pos('[', Name) > 0 then Result := False;
- if Pos(']', Name) > 0 then Result := False;
- end;
- function StatusLevelDescription(Level : Integer) : String;
- begin
- case Level of
- STAT_CRITICALERROR : Result := 'Critical Errors';
- STAT_SERVERERROR : Result := 'Server Errors';
- STAT_SERVEREVENT : Result := 'Server Events';
- STAT_CONNECTIONERROR : Result := 'Connection Errors';
- STAT_CONNECTIONEVENT : Result := 'Connection Events';
- STAT_COMMANDERROR : Result := 'Command Errors';
- STAT_COMMANDEVENT : Result := 'Command Events';
- end;
- end;
- end.