imapcopy-1.04/0000755000175000017500000000000011411434022012241 5ustar errgeerrgeimapcopy-1.04/imapcopymain.pas0000664000175000017500000006541511230432363015456 0ustar errgeerrge{********************************************************************** $Id: imapcopymain.pas,v 1.00 This file is part of imapcopy Copyright (c) 2001-2009 Armin Diehl This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} { ad 2001/10/08: Problem if copying INBOX and Source and Dest are supporting Namespace -> INBOX.INBOX was used accept Cfg-File also if lower case (for Linux) ad 2001/10/09: Again INBOX.INBOX if Source does not support NAMESPACE ad 2002/01/26: while fetching the folder list, lotus notes (5.0.8 linux) returns length and the folder name in the next line. That was not supported Notes somtimes returns invalid INTERNALDATES, seems to be that notes does not check dates ;-), now we check the date and in case we got a wrong internaldate, we fetch the rfc822 Date: now ad 2003/07/15: minor changes for compiling with FreePascal 1.0.10 and 1.1 ad 2003/09/12: a last blank line in the config file is no longer needed AllowFlags in config file to remove message flags that are not supported by the destination server Support Tabs in config file Support -e to create empty folders Added -0 to create folders only Added -s to subscribe folders Added -u to subscribe Src-Folder if Select fails ad 2003/09/12: -e was only possible via config file switch CreateEmptyFolders ad 2003/11/21: in case the server returns internaldate with a one digit day, insert a 0 at the first position ad 2003/12/04: Path Separator \\ was not processed as \ ad 2003/12/14: More Problems with Path Seperator (for Notes) Fixed getting Folder List for Notes (Folders with Blanks) ad 2004/03/31: Added option to copy all messages to INBOX Fixed timeout problem in APPEND command ad 2004/05/09: now using ReadALineAndCount to count received bytes while fetching message body. Previous versions assumed that lines within messages are always terminated by CRLF. That was nonsense (Thanks Ciprian Vizitiu for figuring that out) ad 2005/02/25: Applied patch from Christiaan den Besten to supress INBOX.INBOX and Skip match SrcFolder (-M) ad 2005/04/10: Fixed memory leak ad 2006/04/20: Add DenyFlags directive in config file to filter out i.e. the \Recent flag - Sorry Ciprian for the trouble you had with this ad 2009/07/18: added optional conversion of timezones used in append command (see ImapCopy.cfg) } UNIT imapcopymain; {$IFDEF FPC} {$MODE Delphi} {$ENDIF} INTERFACE {$I-} USES SysUtils, Classes, ImapTools, {$IFDEF Win32} WinSock, {$ELSE} {$IFDEF Unix} //Sockets, // for Linux and FreeBSD {$ELSE} Error, Unknown Opsys {$ENDIF} {$ENDIF} GetOpts, logfile; CONST VersionK = '1.04 - 2009/07/18'; PROCEDURE ParseCommandLine; PROCEDURE Header; PROCEDURE Main; IMPLEMENTATION CONST CfgFileK = 'ImapCopy.cfg'; {$IFDEF UNIX} CfgFile2K = 'imapcopy.cfg'; // for Unix {$ENDIF} VAR SrcThisFoldersOnly, SrcSkipFolders : STRING; // List of folders separated by , SrcMatchFolders : TStringList = nil; OnlyOneMessage : BOOLEAN = FALSE; // copy only the first message of each folder CreateEmptyFolders : BOOLEAN = FALSE; // Create Empty Folders also CopyFoldersOnly : BOOLEAN = FALSE; TestMode : BOOLEAN = FALSE; // test login for all users SubscribeFolder : BOOLEAN = FALSE; SubscribeSrcFolder : BOOLEAN = FALSE; CopyAllMessagesToInbox: BOOLEAN = FALSE; AllowFlags : STRING = ''; AllowFlagsList : TStringList; DenyFlags : STRING = ''; DenyFlagsList : TStringList; InfoOnly : BOOLEAN; TotalNumMsgs : INTEGER = 0; TotalErrs : INTEGER = 0; TotalUsers : INTEGER = 0; TotalFoldersCreated : INTEGER = 0; TotalFolderCreateErrs : INTEGER = 0; TotalFoldersNotCopieed: INTEGER = 0; DstRootFolder : STRING = ''; PROCEDURE Header; VAR S : STRING; BEGIN S := 'IMAPCopy '+VersionK; {$IFDEF FPC} S := S + ' [compiled with FreePascal]'; {$ELSE} S := S + ' [compiled with Delphi]'; {$ENDIF} writeln (S); writeln ('written 2001-2009 by Armin Diehl '); {$IFDEF Linux} WriteLn ('Running on Linux'); {$ENDIF} {$IFDEF Win32} WriteLn ('Running on Win32'); {$ENDIF} WriteLn; WriteLn ('This program is free software; you can redistribute it and/or'); WriteLn ('modify it under the terms of the GNU General Public License'); WriteLn ('as published by the Free Software Foundation; either version 2'); WriteLn ('of the License, or (at your option) any later version.'); WriteLn; WriteLn ('This program is distributed in the hope that it will be useful,'); WriteLn ('but WITHOUT ANY WARRANTY; without even the implied warranty of'); WriteLn ('MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the'); WriteLn ('GNU General Public License for more details.'); WriteLn; WriteLn ('You should have received a copy of the GNU General Public License'); WriteLn ('along with this program; if not, write to the Free Software'); WriteLn ('Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.'); WriteLn ('---------------------------------------------------------------------------'); END; PROCEDURE Help; BEGIN WriteLn ('Usage'); WriteLn ('ImapCopy [-h] [-i] [-O SrcFolder] [-S SrcFolder] [-1] [-0] [-s] [-u]'); WriteLn (' -O SrcFolder : Copy only SrcFolder, -O can be specified more than once'); WriteLn (' -M SrcFolder : Skip match SrcFolder, -M can be specified more than once'); WriteLn (' -S SrcFolder : Skip SrcFolder, -S can be specified more than once'); WriteLn (' -i : Show info about servers and exit without copying'); WriteLn (' -1 : Copy only the first message of each folder'); WriteLn (' -0 : Copy folders only, dont copy any messages'); WriteLn (' -e : Create emtpy folders also'); WriteLn (' -t : Test login for all users in config file'); WriteLn (' -s : Subscribe all folders on destination server'); WriteLn (' -u : Subscribe all folders on Source, needed by some servers to'); WriteLn (' select a folder (only if select failes)'); WriteLn (' -X : Copy all Messages to INBOX, dont create Folders on Destination'); Writeln (' -l : Write results to logfile imapcopy.log'); HALT(1); END; FUNCTION CfgNextWord (VAR S : STRING) : STRING; VAR P : INTEGER; BEGIN DelGarbage (S); P := POS (#9, S); WHILE P > 0 DO BEGIN S[P] := ' '; P := POS (#9, S); END; IF Length (S) = 0 THEN BEGIN Result := S; EXIT; END; IF S[1] = '"' THEN BEGIN P := 2; WHILE (P <= Length (S)) AND (S[P] <> '"') DO INC (P); Result := Copy (S,2,P-2); Delete (S,1,P); END ELSE BEGIN P := Pos (' ', S); IF P = 0 THEN BEGIN Result := S; S := ''; END ELSE BEGIN Result := Copy (S,1,P-1); Delete (S,1,P); END; END; END; PROCEDURE ParseCommandLine; VAR C : CHAR; BEGIN InfoOnly := FALSE; SrcSkipFolders := ''; SrcThisFoldersOnly := ''; REPEAT C := GetOpt ('h?HO:S:i1t0sueXl'); CASE C OF '?','h','H' : Help; 'S' : SrcSkipFolders := SrcSkipFolders + OptArg + ','; 'M' : BEGIN IF SrcMatchFolders = nil then SrcMatchFolders := TStringList.Create; SrcMatchFolders.Add (OptArg); END; 'O' : SrcThisFoldersOnly := SrcThisFoldersOnly + OptArg + ','; 'i' : InfoOnly := TRUE; '1' : OnlyOneMessage := TRUE; 'e' : CreateEmptyFolders := TRUE; 't' : TestMode := TRUE; '0' : CopyFoldersOnly := TRUE; 's' : SubscribeFolder := TRUE; 'u' : SubscribeSrcFolder := TRUE; 'X' : CopyAllMessagesToInbox := TRUE; 'l' : begin logfile.log_to_file := TRUE; if not logfile.log_openfile ('') then begin writeln (paramstr(0),': unable to open logfile'); halt(2); end; end; END; UNTIL C = EndOfOptions; END; // Dont know if spaces between flags are always present, support both FUNCTION Flags2StringList (Flags : STRING) : TStringList; VAR P : PCHAR; F : STRING; BEGIN Result := TStringList.Create; P := PChar (Flags); F := ''; WHILE P^ <> #0 DO BEGIN IF ((P^ = '\') OR (P^ = ' ')) AND (F <> '') THEN BEGIN F := Trim (F); IF F <> '' THEN Result.Add (Trim(F)); F := ''; END; F := F + P^; INC (P); END; IF F <> '' THEN Result.Add (Trim(F)); END; PROCEDURE RemoveUnsupportedFlags (VAR Flags : STRING); VAR F : TStringList; I : INTEGER; BEGIN IF AllowFlags <> '' THEN IF Flags <> '' THEN BEGIN IF AllowFlagsList = NIL THEN AllowFlagsList := Flags2StringList (AllowFlags); F := Flags2StringList (Flags); Flags := ''; IF F.Count > 0 THEN BEGIN FOR I := 0 TO F.Count-1 DO IF AllowFlagsList.IndexOf(F[I]) >= 0 THEN Flags := Flags + F[I] + ' '; Flags := Trim (Flags); END; END; IF DenyFlags <> '' THEN IF Flags <> '' THEN BEGIN IF DenyFlagsList = NIL THEN DenyFlagsList := Flags2StringList (DenyFlags); F := Flags2StringList (Flags); Flags := ''; IF F.Count > 0 THEN BEGIN FOR I := 0 TO F.Count-1 DO IF DenyFlagsList.IndexOf(F[I]) < 0 THEN Flags := Flags + F[I] + ' '; Flags := Trim (Flags); END; END; END; PROCEDURE Main; VAR Src,Dst : ImapServer; Cmd,Line,SrcServer,DstServer: STRING; SrcPort,DstPort : WORD; T : TEXT; Err : INTEGER; SrcUser, DstUser, SrcPasswd, DstPasswd, S,S2 : STRING; I : INTEGER; DebugCommandsSrc : BOOLEAN; DebugCommandsDst : BOOLEAN; NumUserMessages,NumUserErrs : integer; FUNCTION FolderCopyCheck (SrcFolder : STRING) : BOOLEAN; VAR I : INTEGER; BEGIN Result := FALSE; IF SrcThisFoldersOnly <> '' THEN IF Pos (SrcFolder+',',SrcThisFoldersOnly) = 0 THEN EXIT; IF SrcSkipFolders <> '' THEN IF Pos (SrcFolder+',',SrcSkipFolders) <> 0 THEN EXIT; IF SrcMatchFolders <> nil THEN FOR I := 0 TO SrcMatchFolders.Count-1 DO IF Pos (SrcMatchFolders [I], SrcFolder) = 1 THEN EXIT; Result := TRUE; END; PROCEDURE CopyAllMessages (SrcFolder : STRING); VAR DstFolder,S : STRING; Err : INTEGER; P : INTEGER; MailMessage, MailFlags, MailTime : STRING; NumMsgs, NumErrs, Max : INTEGER; F : FILE; BEGIN IF NOT FolderCopyCheck (SrcFolder) THEN BEGIN Log (log_message, 'Skipping '+SrcFolder); EXIT; END; IF Src.isPublicFolder (SrcFolder) THEN BEGIN Log (log_message, 'Skipping Public Folder '+SrcFolder); EXIT; END; IF Src.isOtherUsersFoler (SrcFolder) THEN BEGIN Log (log_message, 'Skipping other users Folder '+SrcFolder); EXIT; END; Write ('Getting List of messages in "'+SrcFolder+'" '); Err := Src.SelectMailbox (SrcFolder); // some servers dont support selecting a mailbox that is not // subscribed IF (Err <> 0) AND (SubscribeSrcFolder) THEN BEGIN Log (log_warning, 'SELECT '+SrcFolder+' failed, trying to SUBSCRIBE'); Src.SubscribeMailbox (SrcFolder); Err := Src.SelectMailbox (SrcFolder); END; IF Err <> 0 THEN BEGIN Log (log_error, 'Failed (SELECT)- copy aborted for this folder'); INC (TotalErrs); INC (NumUserErrs); INC (TotalFoldersNotCopieed); EXIT; END; WriteLn ('OK, ',Src.NumMessages,' Messages found'); IF Src.NumMessages = 0 THEN IF NOT CreateEmptyFolders THEN IF NOT CopyFoldersOnly THEN BEGIN log (log_message, 'Folder '+SrcFolder+' contains no messages - skipping'); EXIT; END; WriteLn ('Processing Folder ',SrcFolder); NumMsgs := 0; NumErrs := 0; IF NOT CopyAllMessagesToInbox THEN BEGIN DstFolder := Dst.NamespaceUser; IF DstRootFolder <> '' THEN // AD 2003/12/14 BEGIN IF DstFolder <> '' THEN DstFolder := DstFolder + Dst.PathSep; DstFolder := DstFolder + DstRootFolder; END; IF (SrcFolder <> Src.NamespaceUser) AND (SrcFolder <> 'INBOX') THEN // AD 2001/10/09 BEGIN S := Src.RemovePersonalNamespace (SrcFolder); P := Pos (Src.PathSep, S); WHILE (P > 0) DO BEGIN IF DstFolder <> '' THEN DstFolder := DstFolder + Dst.PathSep; DstFolder := DstFolder + Copy (S,1,P-1); Delete (S,1,P-1+Length(Src.PathSep)); P := Pos (Src.PathSep, S); END; IF DstFolder <> '' THEN DstFolder := DstFolder + Dst.PathSep; DstFolder := DstFolder + S; END ELSE // AD 2001/10/03 BEGIN // is root DstFolder := Dst.NamespaceUser; IF DstFolder = '' THEN DstFolder := 'INBOX'; END; END ELSE BEGIN // copy all messages to INBOX DstFolder := Dst.NamespaceUser; IF DstFolder = '' THEN DstFolder := 'INBOX'; END; IF (Pos ('INBOX.INBOX.', DstFolder) = 1) THEN Delete (DstFolder, 1, 6); Err := Dst.SelectMailbox (DstFolder); IF Err <> 0 THEN BEGIN Write ('Creating folder "'+DstFolder+'" '); Err := Dst.CreateMailbox (DstFolder); IF Err <> 0 THEN BEGIN WriteLn ('FAILED'); Log (log_error, 'Create Destination Folder ("'+DstFolder+'") failed - copy for this folder aborted'); INC (TotalFolderCreateErrs); INC (NumUserErrs); INC (TotalFoldersNotCopieed); EXIT; END ELSE BEGIN WriteLn ('OK'); INC (TotalFoldersCreated); END; Err := Dst.SelectMailbox (DstFolder); IF Err <> 0 THEN BEGIN Log (log_error, 'Select after Create Destination Folder ("'+DstFolder+'") failed - copy for this folder aborted'); INC (TotalErrs); INC (NumUserErrs); INC (TotalFoldersNotCopieed); EXIT; END; END; IF SubscribeFolder THEN BEGIN Err := Dst.SubscribeMailbox (DstFolder); IF Err <> 0 THEN BEGIN Log (log_warning, 'Subscribe Destination Folder ("'+DstFolder+'") failed - will continue'); INC (TotalErrs); INC (NumUserErrs); END ELSE Log (log_message, 'Subscribed Folder "'+DstFolder+'"'); END; Max := Src.NumMessages; IF Max > 0 THEN BEGIN IF OnlyOneMessage THEN Max := 1; IF CopyFoldersOnly THEN Max := 0; END; IF Max > 0 THEN BEGIN FOR P := 1 TO Max DO BEGIN Write (#13,'reading message ',P); MailFlags := Src.MessageFlags (P); MailTime := Src.MessageDate (P); IF MailTime = '' THEN MailTime := Src.RFC822MessageDate (P); // for Lotus notes, sometimes notes returns invalid dates MailMessage := Src.MessageBody (P); IF MailMessage <> '' THEN BEGIN Write (#13,'WRITING'); {Retry := 0; REPEAT Err := Dst.MessageSave (DstFolder,MailMessage,MailFlags,MailTime); INC (Retry); IF (Err <> WSAECONNABORTED) AND (Err <> WSAECONNRESET) THEN Retry := 10; // the mercury v3.30 beta sometimes closes the connection !???@@!! UNTIL (Err = 0) OR (Retry > 2); -- this was a test, it seems to be an error in mercury } RemoveUnsupportedFlags (MailFlags); Err := Dst.MessageSave (DstFolder,MailMessage,MailFlags,MailTime); IF Err <> 0 THEN BEGIN Write (#13); Log (log_error,'Error saving message '+IntToStr(P)+', continuing copy, Server returned "'+Dst.LastResult+'"'); INC (NumErrs); INC (NumUserErrs); INC (TotalErrs); // Save failed message Assign (F,'FailedMail.dat'); ReWrite (F,1); BlockWrite (F,MailMessage[1], Length (MailMessage)); Close (F); END ELSE BEGIN INC (NumMsgs); INC (NumUserMessages); INC (TotalNumMsgs); END; END ELSE BEGIN Write (#13); Log (Log_warning,'WARNING: Empty body for message '+IntToStr(P)+' received from server, skipping message'); INC (NumErrs); INC (NumUserErrs); INC (TotalErrs); END; END; Write (#13); if logfile.log_to_file then Log (log_status,IntToStr(NumMsgs)+' Messages copied, '+IntToStr(NumErrs)+' Errors ('+SrcFolder+' -> '+DstFolder+')') else Log (log_status,IntToStr(NumMsgs)+' Messages copied, '+IntToStr(NumErrs)+' Errors'); END ELSE IF NOT CopyFoldersOnly THEN Log (log_message, 'Folder contains no messages - skipping'); END; BEGIN Assign (T,CfgFileK); Reset (T); {$IFDEF Unix} IF IOResult <> 0 THEN BEGIN // check lower case Assign (T,CfgFile2K); Reset (T); END; {$ENDIF} IF IOResult <> 0 THEN BEGIN {$IFDEF Unix} WriteLn (CfgFileK+' or '+CfgFile2K+' not found'); {$else} WriteLn (CfgFileK+' not found'); {$ENDIF} EXIT; END; SrcServer := ''; DstServer := ''; SrcPort := 0; DstPort := 0; Src := NIL; Dst := NIL; DebugCommandsSrc := FALSE; DebugCommandsDst := FALSE; TotalNumMsgs := 0; TotalErrs := 0; REPEAT Readln (T, Line); IF (Copy (Line,1,1) = '#') OR (Copy (Line,1,1) = ';') THEN cmd := '' ELSE Cmd := lowerCase (CfgNextWord (Line)); IF (Cmd = '') OR (cmd = '#') OR (cmd = ';') THEN BEGIN END ELSE IF Cmd = 'skipfolder' THEN SrcSkipFolders := SrcSkipFolders + CfgNextWord (Line) + ',' ELSE IF Cmd = 'skipmatch' THEN BEGIN IF SrcMatchFolders = nil then SrcMatchFolders := TStringList.Create; SrcMatchFolders.Add (CfgNextWord (Line)); END ELSE IF Cmd = 'copyfolder' THEN SrcThisFoldersOnly := SrcThisFoldersOnly + CfgNextWord (Line) + ',' ELSE IF Cmd = 'createemptyfolders' THEN CreateEmptyFolders := TRUE ELSE IF Cmd = 'debugsrc' THEN DebugCommandsSrc := TRUE ELSE IF Cmd = 'debugdst' THEN DebugCommandsDst := TRUE ELSE IF Cmd = 'sourceserver' THEN SrcServer := CfgNextWord (Line) ELSE IF Cmd = 'destserver' THEN DstServer := CfgNextWord (Line) ELSE IF Cmd = 'sourceport' THEN SrcPort := Word (StrToInt (CfgNextWord (Line))) ELSE IF Cmd = 'destport' THEN DstPort := Word (StrToInt (CfgNextWord (Line))) ELSE IF Cmd = 'allowflags' THEN AllowFlags := CfgNextWord (Line) ELSE IF Cmd = 'denyflags' THEN DenyFlags := CfgNextWord (Line) ELSE IF Cmd = 'copyfoldersonly' THEN CopyFoldersOnly := TRUE ELSE IF Cmd = 'subscribefolder' THEN SubscribeFolder := TRUE ELSE IF Cmd = 'subscribesrcfolder' THEN SubscribeFolder := TRUE ELSE IF Cmd = 'dstrootfolder' THEN DstRootFolder := CfgNextWord (Line) ELSE IF Cmd = 'converttimezone' THEN BEGIN S := CfgNextWord(Line); S2 := CfgNextWord(Line); AddTimeZoneConversionEntry (S,S2); END ELSE IF Cmd = 'copy' THEN BEGIN IF Src = NIL THEN BEGIN IF SrcServer = '' THEN BEGIN log (log_fatal, 'SourceServer missing in configfile'); EXIT; END; Src := ImapServer.Create; Err := Src.Connect (SrcServer, SrcPort); IF Err <> 0 THEN BEGIN log (log_fatal, 'Unable to connect to source imap-server "'+SrcServer+':'+IntToStr(SrcPort)+'"'); EXIT; END; END; IF Dst = NIL THEN BEGIN IF DstServer = '' THEN BEGIN log (log_fatal, 'DestServer missing in configfile'); EXIT; END; Dst := ImapServer.Create; Err := Dst.Connect (DstServer, DstPort); IF Err <> 0 THEN BEGIN log (log_fatal, 'Unable to connect to destination imap-server "'+DstServer+':'+IntToStr(DstPort)+'"'); EXIT; END; END; SrcUser := CfgNextWord (Line); SrcPasswd := CfgNextWord (Line); DstUser := CfgNextWord (Line); DstPasswd := CfgNextWord (Line); NumUserMessages := 0; NumUserErrs := 0; IF DstUser = '*' THEN DstUser := SrcUser; IF DstPasswd = '*' THEN DstPasswd := SrcPasswd; log (log_file,'---- Beginning copy of '+SrcUser); Write ('Login on sourceserver as '+SrcUser+' '); Err := Src.Login (SrcUser, SrcPasswd); IF Err = 0 THEN BEGIN WriteLn ('OK'); Write ('Login on destinationserver as '+DstUser+' '); Err := Dst.Login (DstUser, DstPasswd); IF Err = 0 THEN BEGIN WriteLn ('OK'); INC (TotalUsers); Src.DebugCommands := DebugCommandsSrc; Dst.DebugCommands := DebugCommandsDst; IF InfoOnly THEN BEGIN WriteLn ('Sourceserver:'); WriteLn ('============='); WriteLn ('Server-Info : ',Src.ServerInfo); WriteLn ('Capabilities : ',Src.Capabilities); WriteLn ('Personal Namespace : ',Src.NamespaceUser); WriteLn ('Folder sperator : ',Src.PathSep); WriteLn ('other Users Namespace: ', Src.NamespaceOtherUser); WriteLn ('Public Namespace : ', Src.NamespacePublicFolders); IF SrcThisFoldersOnly <> '' THEN S := SrcThisFoldersOnly ELSE S := 'ALL'; WriteLn ('Folders to copy : ',S); IF SrcSkipFolders <> '' THEN S := SrcSkipFolders ELSE S := 'NONE'; WriteLn ('Skip this folders : ',S); WriteLn; WriteLn ('Destinationserver:'); WriteLn ('=================='); WriteLn ('Server-Info : ',Dst.ServerInfo); WriteLn ('Capabilities : ',Dst.Capabilities); WriteLn ('Personal Namespace : ',Dst.NamespaceUser); WriteLn ('Folder sperator : ',Dst.PathSep); WriteLn ('other Users Namespace: ', Dst.NamespaceOtherUser); WriteLn ('Public Namespace : ', Dst.NamespacePublicFolders); Src.Free; Dst.Free; HALT; END ELSE BEGIN Write ('Getting folderlist on sourceserver '); Err := Src.GetMailboxList; IF Err = 0 THEN BEGIN WriteLn ('OK, found ',Src.MailboxList.Count,' folder'); IF DebugCommandsSrc THEN BEGIN FOR I := 0 TO Src.MailboxList.Count-1 DO Writeln (Src.MailboxList[I]); Writeln; END; IF Src.MailboxList.Count > 0 THEN BEGIN IF DstRootFolder <> '' THEN BEGIN S := Dst.NamespaceUser; IF S <> '' THEN S := S + Dst.PathSep; S := S + DstRootFolder; Writeln ('Creating Rootfolder '+S); Err := Dst.SelectMailbox (S); IF Err <> 0 THEN BEGIN Write ('Creating rootfolder "'+S+'" '); Err := Dst.CreateMailbox (S); IF Err <> 0 THEN BEGIN WriteLn ('FAILED'); log (log_error, 'Create Destination Folder ("'+S+'") failed - copy aborted'); INC (TotalFolderCreateErrs); INC (NumUserErrs); EXIT; END ELSE Writeln ('Ok'); END; IF SubscribeFolder THEN BEGIN Err := Dst.SubscribeMailbox (S); IF Err <> 0 THEN BEGIN log (log_warning,'Subscribe Destination Folder ("'+S+'") failed - will continue'); INC (TotalErrs); END ELSE log (log_message, 'Subscribed Folder "'+S+'"'); END; END; IF NOT TestMode THEN FOR I := 0 TO Src.MailboxList.Count-1 DO CopyAllMessages (Src.MailboxList[I]); END ELSE Log (log_error,'no folders found on source ?? at least INBOX has to be there !'); END ELSE BEGIN WriteLn ('FAILED - copy aborted for this user'); log (log_error,'Getting Folderlist for User '+SrcUser+' failed'); END; END; Src.Logout; Dst.Logout; if NumUserErrs > 0 then log (log_error,'Total Errors for User "'+SrcUser+'": '+IntToStr(NumUserErrs)); Log (log_file,'---- End of job for user "'+SrcUser+'", copied '+IntToStr(NumUserMessages)+' Message(s)'); END ELSE BEGIN WriteLn ('FAILED !'); log (log_fatal, 'Login on destinationserver as '+DstUser+' failed'); Src.Logout; END; IF Src <> NIL THEN BEGIN Src.Free; Src := NIL; END; IF Dst <> NIL THEN BEGIN Dst.Free; Dst := NIL; END; END ELSE BEGIN WriteLn ('FAILED !'); log (log_fatal,'Login on sourceserver as '+SrcUser+' failed'); END; END ELSE BEGIN log (log_fatal,'Unkown command ('+cmd+') found in configfile'); EXIT; END; UNTIL EOF (T); WriteLn; log (log_status,IntToStr(TotalUsers)+' User processed, '+IntToStr(TotalNumMsgs)+' Messages copied, '+IntToStr(TotalErrs)+' Error(s)'); log (log_status,IntToStr(TotalFoldersCreated)+' Folder(s) created, '+IntToStr(TotalFolderCreateErrs)+' Folder create errors, '+IntToStr(TotalFoldersNotCopieed)+' Folder not copied'); END; BEGIN AllowFlagsList := NIL; END. imapcopy-1.04/Dist/0000755000175000017500000000000011411434022013144 5ustar errgeerrgeimapcopy-1.04/Dist/ImapCopy.cfg0000620000175000017500000000506711230422436015355 0ustar errgeerrge############################################################# # imapcopy config # all lines beginning with # are comments and will be ignored ############################################################# ############## # Sourceserver ############## SourceServer localhost SourcePort 143 ################### # Destinationserver ################### DestServer localhost DestPort 143 ######### # Options ######### # # DebugSrc and DebugDest will show all traffic between IMAPCopy and Server # #DebugSrc #DebugDst ################# # Folders to skip ################# #skipfolder INBOX.Trash #skipfolder INBOX.Sent #skipfolder "INBOX.Sent Objects" ################# # Folders to copy ################# #copyfolder INBOX #copyfolder "INBOX.My personal files" #copyfolder INBOX.Net-Connection.dy #copyfolder INBOX.test ####################################################### # Rootfolder # Can be specified to copy the Folder-Structure under # a separate folder instead of inbox ####################################################### #DstRootFolder "Your old Mails" ############################################################### # Specify Flags that are supported on the destination server # (AllowFlags) or flags that should be filtered out (DenyFlags) # If not specified, all Flags are copyied 1:1 # If AllowFlags is specified, all not specified Flags will be # removed and not copied to the destination # If DenyFlags is specified, those flags will be removed and # the remaining ones will be copied # Both (AllowFlags and DenyFlags) could be specified but # would (in most cases) make no sense ############################################################## #AllowFlags "\Seen\Answered\Flagged\Deleted\Draft Junk NonJunk $MDNSent $Forwared" DenyFlags "\Recent" ############################################################## # Timezone conversion # The imap rfc is not clear on what kind of time offsets # can be used. +XXXX -XXXX will be supported on all servers # You can add as many entries as needed in the form # converttimezone SRC DST # to convert zones that your target server rejects ############################################################## converttimezone "UTC" "+0000" converttimezone "UT" "+0000" ############################# # List of users and passwords ############################# # SourceUser SourcePassword DestinationUser DestinationPassword Copy "foo" "foosrcpw" "foo" "foodestpw" Copy "bar" "barsrcpw" "bar" "test" imapcopy-1.04/Delphi/0000755000175000017500000000000011411434022013446 5ustar errgeerrgeimapcopy-1.04/Delphi/GetOpts.pas0000644000175000017500000003410407333070140015547 0ustar errgeerrge{ $Id: getopts.pp,v 1.3 2001/01/11 18:38:24 peter Exp $ This file is part of the Free Pascal run time library. Copyright (c) 1999-2000 by Michael Van Canneyt, member of the Free Pascal development team. Getopt implementation for Free Pascal, modeled after GNU getopt See the file COPYING.FPC, included in this distribution, for details about the copyright. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. Modified 2001/08/05 AD to compile unter delphi also **********************************************************************} unit getopts; Interface Const No_Argument = 0; Required_Argument = 1; Optional_Argument = 2; EndOfOptions = #255; Type POption = ^TOption; TOption = Record Name : String; Has_arg : Integer; Flag : PChar; Value : Char; end; Orderings = (require_order,permute,return_in_order); Const OptSpecifier : set of char=['-']; Var OptArg : String; OptInd : Longint; OptErr : Boolean; OptOpt : Char; Function GetOpt (ShortOpts : String) : char; Function GetLongOpts (ShortOpts : String;LongOpts : POption;var Longind : Longint) : char; Implementation {$ifndef FPC} {$define TP} {$endif} {$ifdef TP} {$ifndef win32} uses strings; {$else} uses sysutils; {$endif} {$endif} {*************************************************************************** Create an ArgV ***************************************************************************} {$ifdef TP} {$ifdef win32} function GetCommandLine: PChar; stdcall; external 'kernel32.dll' name 'GetCommandLineA'; {$else} function GetCommandLine:pchar; begin GetCommandLine:=ptr(prefixseg,$81); end; {$endif} {$ifdef win32} VAR ParamStr0 : STRING; function GetCommandFile:pchar; begin ParamStr0 := ParamStr (0); Result := PChar (ParamStr0); end; {$else} function GetCommandFile:pchar; var p : pchar; begin p:=ptr(memw[prefixseg:$2c],0); repeat while p^<>#0 do inc(longint(p)); { next char also #0 ? } inc(longint(p)); if p^=#0 then begin inc(longint(p),3); GetCommandFile:=p; exit; end; until false; end; {$endif} type ppchar = ^pchar; apchar = array[0..127] of pchar; var argc : longint; argv : apchar; procedure setup_arguments; var arglen, count : longint; argstart, cmdline : pchar; quote : set of char; argsbuf : array[0..127] of pchar; begin { create argv[0] which is the started filename } argstart:=GetCommandFile; arglen:=strlen(argstart)+1; getmem(argsbuf[0],arglen); move(argstart^,argsbuf[0]^,arglen); { create commandline } cmdline:=GetCommandLine; count:=1; repeat { skip leading spaces } while cmdline^ in [' ',#9,#13] do inc(longint(cmdline)); case cmdline^ of #0 : break; '"' : begin quote:=['"']; inc(longint(cmdline)); end; '''' : begin quote:=['''']; inc(longint(cmdline)); end; else quote:=[' ',#9,#13]; end; { scan until the end of the argument } argstart:=cmdline; while (cmdline^<>#0) and not(cmdline^ in quote) do inc(longint(cmdline)); { reserve some memory } arglen:=cmdline-argstart; getmem(argsbuf[count],arglen+1); move(argstart^,argsbuf[count]^,arglen); argsbuf[count][arglen]:=#0; { skip quote } if cmdline^ in quote then inc(longint(cmdline)); inc(count); until false; { create argc } argc:=count; { create an nil entry } argsbuf[count]:=nil; inc(count); { create the argv } move(argsbuf,argv,count shl 2); end; {$endif TP} {*************************************************************************** Real Getopts ***************************************************************************} Var NextChar, Nrargs, first_nonopt, last_nonopt : Longint; Ordering : Orderings; Procedure Exchange; var bottom, middle, top,i,len : longint; temp : pchar; begin bottom:=first_nonopt; middle:=last_nonopt; top:=optind; while (top>middle) and (middle>bottom) do begin if (top-middle>middle-bottom) then begin len:=middle-bottom; for i:=1 to len-1 do begin temp:=argv[bottom+i]; argv[bottom+i]:=argv[top-(middle-bottom)+i]; argv[top-(middle-bottom)+i]:=temp; end; top:=top-len; end else begin len:=top-middle; for i:=0 to len-1 do begin temp:=argv[bottom+i]; argv[bottom+i]:=argv[middle+i]; argv[middle+i]:=temp; end; bottom:=bottom+len; end; end; first_nonopt:=first_nonopt + optind-last_nonopt; last_nonopt:=optind; end; { exchange } procedure getopt_init (var opts : string); begin { Initialize some defaults. } Optarg:=''; Optind:=1; First_nonopt:=1; Last_nonopt:=1; OptOpt:='?'; Nextchar:=0; case opts[1] of '-' : begin ordering:=return_in_order; delete(opts,1,1); end; '+' : begin ordering:=require_order; delete(opts,1,1); end; else ordering:=permute; end; end; Function Internal_getopt (Var Optstring : string;LongOpts : POption; LongInd : pointer;Long_only : boolean ) : char; type pinteger=^integer; var temp,endopt, option_index : byte; indfound : integer; currentarg, optname : string; p,pfound : POption; exact,ambig : boolean; c : char; begin optarg:=''; if optind=0 then getopt_init(optstring); { Check if We need the next argument. } if (optindlast_nonopt) and (last_nonopt<>optind) then exchange else if last_nonopt<>optind then first_nonopt:=optind; while (optindnrargs) and (currentarg='--') then begin inc(optind); if (first_nonopt<>last_nonopt) and (last_nonopt<>optind) then exchange else if first_nonopt=last_nonopt then first_nonopt:=optind; last_nonopt:=nrargs; optind:=nrargs; end; { Are we at the end of all arguments ? } if optind>=nrargs then begin if first_nonopt<>last_nonopt then optind:=first_nonopt; Internal_getopt:=EndOfOptions; exit; end; if optindnil) and ((currentarg[2]='-') and (currentArg[1]='-')) then inc(nextchar); { So, now nextchar points at the first character of an option } end; { Check if we have a long option } if longopts<>nil then if length(currentarg)>1 then if ((currentarg[2]='-') and (currentArg[1]='-')) or ((not long_only) and (pos(currentarg[2],optstring)<>0)) then begin { Get option name } endopt:=pos('=',currentarg); if endopt=0 then endopt:=length(currentarg)+1; optname:=copy(currentarg,nextchar,endopt-nextchar); { Match partial or full } p:=longopts; pfound:=nil; exact:=false; ambig:=false; option_index:=0; indfound:=0; while (p^.name<>'') and (not exact) do begin if pos(optname,p^.name)<>0 then begin if length(optname)=length(p^.name) then begin exact:=true; pfound:=p; indfound:=option_index; end else if pfound=nil then begin indfound:=option_index; pfound:=p end else ambig:=true; end; inc(longint(p),sizeof(toption)); inc(option_index); end; if ambig and not exact then begin if opterr then writeln(argv[0],': option "',optname,'" is ambiguous'); nextchar:=0; inc(optind); Internal_getopt:='?'; end; if pfound<>nil then begin inc(optind); if endopt<=length(currentarg) then begin if pfound^.has_arg>0 then optarg:=copy(currentarg,endopt+1,length(currentarg)-endopt) else begin if opterr then if currentarg[2]='-' then writeln(argv[0],': option "--',pfound^.name,'" doesn''t allow an argument') else writeln(argv[0],': option "',currentarg[1],pfound^.name,'" doesn''t allow an argument'); nextchar:=0; internal_getopt:='?'; exit; end; end else { argument in next paramstr... } begin if pfound^.has_arg=1 then begin if optindnil then pinteger(longind)^:=indfound+1; if pfound^.flag<>nil then begin pfound^.flag^:=pfound^.value; internal_getopt:=#0; exit; end; internal_getopt:=pfound^.value; exit; end; { pfound<>nil } { We didn't find it as an option } if (not long_only) or ((currentarg[2]='-') or (pos(CurrentArg[nextchar],optstring)=0)) then begin if opterr then if currentarg[2]='-' then writeln(argv[0],' unrecognized option "--',optname,'"') else writeln(argv[0],' unrecognized option "',currentarg[1],optname,'"'); nextchar:=0; inc(optind); Internal_getopt:='?'; exit; end; end; { Of long options.} { We check for a short option. } temp:=pos(currentarg[nextchar],optstring); c:=currentarg[nextchar]; inc(nextchar); if nextchar>length(currentarg) then begin inc(optind); nextchar:=0; end; if (temp=0) or (c=':') then begin if opterr then writeln(argv[0],': illegal option -- ',c); optopt:=c; internal_getopt:='?'; exit; end; Internal_getopt:=optstring[temp]; if optstring[temp+1]=':' then if optstring[temp+2]=':' then begin { optional argument } if nextchar>0 then begin optarg:=copy (currentarg,nextchar,length(currentarg)-nextchar+1); inc(optind); nextchar:=0; end else if (optind<>nrargs) then begin optarg:=strpas(argv[optind]); if optarg[1]='-' then optarg:='' else inc(optind); nextchar:=0; end; end else begin { required argument } if nextchar>0 then begin optarg:=copy (currentarg,nextchar,length(currentarg)-nextchar+1); inc(optind); end else if (optind=nrargs) then begin if opterr then writeln (argv[0],': option requires an argument -- ',optstring[temp]); optopt:=optstring[temp]; if optstring[1]=':' then Internal_getopt:=':' else Internal_Getopt:='?'; end else begin optarg:=strpas(argv[optind]); inc(optind) end; nextchar:=0; end; { End of required argument} end; { End of internal getopt...} Function GetOpt(ShortOpts : String) : char; begin getopt:=internal_getopt(shortopts,nil,nil,false); end; Function GetLongOpts(ShortOpts : String;LongOpts : POption;var Longind : Longint) : char; begin getlongopts:=internal_getopt(shortopts,longopts,@longind,true); end; begin { create argv if running under TP } {$ifdef TP} setup_arguments; {$endif} { Needed to detect startup } Opterr:=true; Optind:=0; nrargs:=argc; end. { $Log: getopts.pp,v $ Revision 1.3 2001/01/11 18:38:24 peter * patch from bug repository Revision 1.2 2000/07/13 11:33:43 michael + removed logs } imapcopy-1.04/Mkdistsrc0000755000175000017500000000146511230431605014143 0ustar errgeerrge#!/bin/sh # # build imapcopy for win32 and linux # create bin zip/gz and source zip # [ -f DistSrc/IMAPCopySrc.zip ] && rm -f DistSrc/IMAPCopySrc.zip zip DistSrc/IMAPCopySrc.zip *.dpr *.pp *.pas *.inc *.dof Delphi/*.pas Dist/*.cfg Mkdistsrc [ -d Dist/imapcopy ] || mkdir Dist/imapcopy echo "Compiling for Linux" fpc -g -gl -B imapcopy.pp || exit 1 echo "Compiling for Win32" fpc -Twin32 -g -gl -B imapcopy.pp || exit 1 #strip imapcopy || exit 1 cp imapcopy Dist/imapcopy || exit 1 cp Dist/ImapCopy.cfg Dist/imapcopy || exit 1 dos2unix Dist/imapcopy/ImapCopy.cfg cd Dist tar c imapcopy > imapcopy.tar || exit 1 gzip -f imapcopy.tar || exit 1 echo "linux source and binary created" [ -f IMAPCopy.zip ] && rm -f IMAPCopy.zip cp ../imapcopy.exe . zip IMAPCopy.zip *.exe *.cfg || exit 1 cd .. echo "Windows binary created" imapcopy-1.04/inet.pp0000644000175000017500000003074407730325550013567 0ustar errgeerrgeUnit inet; { -------------------------------------------------------------------- Unit for internet domain calls. Copyright (C) 1997 Michael Van Canneyt This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ChangeLog --------- Current version is 0.6 Version Date Remarks ------- ---- ---- 0.1 07/16/97 Unit started. Michael. 0.2 07/06/98 Updated for version 0.99.5 0.4 08/01/98 Objects for name lookup implemented 0.5 09/10/98 Updated calls for 0.99.8. 0.6 05/04/99 Added explicit asmmode. ------------------------------------------------------------------- } interface {$LINKLIB c} Const { Net type } AF_INET = 2; { Error constants. Returned by LastError method of THost, TNet} NETDB_INTERNAL= -1; { see errno } NETDB_SUCCESS = 0; { no problem } HOST_NOT_FOUND= 1; { Authoritative Answer Host not found } TRY_AGAIN = 2; { Non-Authoritive Host not found, or SERVERFAIL } NO_RECOVERY = 3; { Non recoverable errors, FORMERR, REFUSED, NOTIMP } NO_DATA = 4; { Valid name, no data record of requested type } NO_ADDRESS = NO_DATA; { no address, look for MX record } Type THostAddr = array[1..4] of byte; PHostAddr = ^THostAddr; Const NoAddress : THostAddr = (0,0,0,0); Type { THostEnt Object } THostEnt = record Name : pchar; { Official name } Aliases : ppchar; { Null-terminated list of aliases} Addrtype : longint; { Host address type } Addrlen : longint; { Length of address } Addrlist : ppchar; { null-terminated list of adresses } end; PHostEnt = ^THostEnt; { TNetEnt object } TNetEnt = record Name : pchar; { Official name } Aliases : ppchar; { Nill-terminated alias list } AddrType : longint; { Net address type } net : Longint; { Network number } end; PNetEnt = ^TNetEnt; TServEnt = record name : pchar; { Service name } aliases : ppchar; { Null-terminated alias list } port : longint; { Port number } proto : pchar; { Protocol to use } end; PServEnt = ^TServEnt; { Pascal Wrapper objects } TSelectType = (stFirst,stNext,stPrevious); THost = Object FHostEntry : PHostEnt; FAlias,FAddr,FError : Longint; Constructor NameLookup (HostName : String); Constructor AddressLookup (Const Address : THostAddr); Destructor Done; Function Name : String; Function GetAddress (Select : TSelectType) : String; Function GetAlias (Select : TSelectType) : String; Function IPAddress : THostAddr; Function IPString : String; Function LastError : Longint; end; TNet = Object FNetEntry : PNetEnt; FAlias,FError : Longint; Constructor NameLookup (NetName : String); Constructor AddressLookup (Const Address : Longint); Destructor Done; Function Name : String; Function GetAlias (Select : TSelectType) : String; Function IPAddress : Longint; Function IPString : String; Function LastError : Longint; end; TService = Object FServiceEntry : PServEnt; FAlias,FError : Longint; Constructor NameLookup (ServiceName,Proto : String); Constructor PortLookup (APort : Longint; Proto: string); Destructor Done; Function Name : String; Function Protocol : String; Function GetAlias (Select : TSelectType) : String; Function Port : Longint; Function LastError : Longint; end; { Pascal style calls } function HostAddrToStr (Entry : THostAddr) : String; function StrToHostAddr (IP : String) : THostAddr; function NetAddrToStr (Entry : Longint) : String; function StrToNetAddr (IP : String) : Longint; Function HostToNet (Host : Longint) : Longint; Function NetToHost (Net : Longint) : Longint; Function ShortHostToNet (Host : integer) : integer; Function ShortNetToHost (Net : integer) : integer; { C style calls, linked in from Libc } function gethostent : PHostEnt; cdecl; external; function gethostbyname ( Name : Pchar) : PHostEnt; cdecl; external; function gethostbyaddr ( Addr : PHostAddr; Len : Longint; HType : Longint) : PHostent ; cdecl; external; procedure sethostent (stayopen : longint); cdecl; external; procedure endhostent; cdecl; external; function getnetent : PNetEnt; cdecl; external; function getnetbyname ( Name : pchar) : PNetEnt; cdecl; external; function getnetbyaddr ( Net : Longint; nettype : Longint) : PNetEnt; cdecl; external; procedure setnetent ( Stayopen : Longint); cdecl; external; procedure endnetent; cdecl; external; function getservent : PServEnt; cdecl; external; function getservbyname (name : pchar ; protocol : pchar) : PServEnt; cdecl; external; function getservbyport (port : longint; protocol : pchar) : PServEnt; cdecl; external; procedure setservent (StayOpen : longint); cdecl; external; procedure endservent; cdecl; external; //var // GetDNSError : longint;external name 'h_errno'; // This does not work with newer glibc's (i.e. RedHat 9) // dummy for now const GetDNSError = 1; implementation Uses strings; function HostAddrToStr (Entry : THostAddr) : String; Var Dummy : String[4]; I : Longint; begin HostAddrToStr:=''; For I:=1 to 4 do begin Str(Entry[I],Dummy); HostAddrToStr:=HostAddrToStr+Dummy; If I<4 Then HostAddrToStr:=HostAddrToStr+'.'; end; end; function StrToHostAddr(IP : String) : THostAddr ; Var Dummy : String[4]; I : Longint; J : Integer; Temp : THostAddr; begin StrToHostAddr:=NoAddress; For I:=1 to 4 do begin If I<4 Then begin J:=Pos('.',IP); If J=0 then exit; Dummy:=Copy(IP,1,J-1); Delete (IP,1,J); end else Dummy:=IP; Val (Dummy,Temp[I],J); If J<>0 then Exit; end; StrToHostAddr:=Temp; end; function NetAddrToStr (Entry : longint) : String; Var Dummy : String[4]; I : Longint; begin NetAddrToStr:=''; For I:=4 downto 1 do begin Str(THostAddr(Entry)[I],Dummy); NetAddrToStr:=NetAddrToStr+Dummy; If I>1 Then NetAddrToStr:=NetAddrToStr+'.'; end; end; function StrToNetAddr(IP : String) : Longint; begin StrToNetAddr:=Longint(StrToHostAddr(IP)); end; Constructor THost.NameLookup (HostName : String); begin HostName:=HostName+#0; FHostEntry:=GetHostByName(pchar(@HostName[1])); If FHostEntry=Nil then FError:=GetDNSError else begin FAlias:=0; FAddr:=0; Ferror:=0; end; end; Constructor THost.AddressLookup (Const Address: THostAddr); begin FHostEntry:=GetHostByAddr(PHostAddr(@Address),SizeOf(Address),AF_INET); If FHostEntry=Nil then FError:=GetDNSError else begin FAlias:=0; FAddr:=0; FError:=0; end; end; Function THost.Name : String; begin Name:=''; If (FHostEntry=Nil) or (FError<>0) then exit; Name:=StrPas(FHostEntry^.Name); end; Function THost.GetAlias (Select : TSelectType) : String; begin GetAlias:=''; If (FHostEntry=Nil) or (FError<>0) then exit; Case Select of stFirst : FAlias:=0; stnext : If FHostEntry^.Aliases[FAlias]<>Nil then Falias:=Falias+1; stprevious : If FAlias=0 Then Exit else FAlias:=FAlias-1; end; If FHostEntry^.Aliases[FAlias]<>Nil then GetAlias:=StrPas(FHostEntry^.Aliases[FAlias]); end; Function THost.GetAddress (Select : TSelectType) : String; begin GetAddress:=''; If (FHostEntry=Nil) or (FError<>0) then exit; Case Select of stFirst : FAddr:=0; stnext : If FHostEntry^.AddrList[FAddr]<>Nil then FAddr:=FAddr+1; stprevious : If FAddr=0 Then Exit else FAddr:=FAddr-1; end; If FHostEntry^.AddrList[FAddr]<>Nil then GetAddress:=HostAddrToStr(PHostAddr(FHostEntry^.AddrList[FAddr])^); end; Function THost.IPstring : String; begin IPString:=''; If (FHostEntry=Nil) or (FError<>0) then exit; If FHostEntry^.AddrList[0]<>Nil then IPString:=HostAddrToStr(PHostAddr(FHostEntry^.AddrList[0])^); end; Function THost.IPaddress : THostAddr; begin IPAddress:=NoAddress; If (FHostEntry=Nil) or (FError<>0) then exit; IPAddress:=PHostAddr(FHostEntry^.AddrList[0])^; end; Destructor THost.Done; begin end; Function THost.LastError : Longint; begin LastError:=FError; end; Constructor TNet.NameLookup (NetName : String); begin NetName:=NetName+#0; FNetEntry:=GetNetByName(pchar(@NetName[1])); If FNetEntry=Nil then FError:=GetDNSError else begin FAlias:=0; Ferror:=0; end; end; Constructor TNet.AddressLookup (Const Address: Longint); begin FNetEntry:=GetNetByAddr(Address,AF_INET); If FNetEntry=Nil then FError:=GetDNSError else begin FAlias:=0; FError:=0; end; end; Function TNet.Name : String; begin Name:=''; If (FNetEntry=Nil) or (FError<>0) then exit; Name:=StrPas(FNetEntry^.Name); end; Function TNet.GetAlias (Select : TSelectType) : String; begin GetAlias:=''; If (FNetEntry=Nil) or (FError<>0) then exit; Case Select of stFirst : FAlias:=0; stnext : If FNetEntry^.Aliases[FAlias]<>Nil then Falias:=Falias+1; stprevious : If FAlias=0 Then Exit else FAlias:=FAlias-1; end; If FNetEntry^.Aliases[FAlias]<>Nil then GetAlias:=StrPas(FNetEntry^.Aliases[FAlias]); end; Function TNet.IPstring : String; begin IPString:=''; If (FNetEntry=Nil) or (FError<>0) then exit; IPString:=NetAddrToStr(FNetEntry^.Net); end; Function TNet.IPaddress : Longint; begin IPAddress:=0; If (FNetEntry=Nil) or (FError<>0) then exit; IPAddress:=FNetEntry^.Net; end; Destructor TNet.Done; begin end; Function TNet.LastError : Longint; begin LastError:=FError; end; Constructor TService.NameLookup (ServiceName,Proto : String); begin ServiceName:=ServiceName+#0; Proto:=Proto+#0; FServiceEntry:=GetServByName(pchar(@ServiceName[1]),pchar(@Proto[1])); If FServiceEntry=Nil then FError:=GetDNSError else begin FAlias:=0; Ferror:=0; end; end; Constructor TService.PortLookup (APort: Longint; Proto : String); begin Proto:=proto+#0; FServiceEntry:=GetServByPort(APort,pchar(@proto[1])); If FServiceEntry=Nil then FError:=GetDNSError else begin FAlias:=0; FError:=0; end; end; Function TService.Name : String; begin Name:=''; If (FServiceEntry=Nil) or (FError<>0) then exit; Name:=StrPas(FServiceEntry^.Name); end; Function TService.GetAlias (Select : TSelectType) : String; begin GetAlias:=''; If (FServiceEntry=Nil) or (FError<>0) then exit; Case Select of stFirst : FAlias:=0; stnext : If FServiceEntry^.Aliases[FAlias]<>Nil then Falias:=Falias+1; stprevious : If FAlias=0 Then Exit else FAlias:=FAlias-1; end; If FServiceEntry^.Aliases[FAlias]<>Nil then GetAlias:=StrPas(FServiceEntry^.Aliases[FAlias]); end; Function TService.Protocol : String; begin Protocol:=''; If (FServiceEntry=Nil) or (FError<>0) then exit; Protocol:=Strpas(FServiceEntry^.proto); end; Function TService.Port : Longint; begin Port:=0; If (FServiceEntry=Nil) or (FError<>0) then exit; Port:=FServiceEntry^.Port; end; Destructor TService.Done; begin end; Function TService.LastError : Longint; begin LastError:=FError; end; Function HostToNet (Host : Longint) : Longint; begin HostToNet:=THostAddr(host)[1]; HostToNEt:=HostTONet or ( (THostAddr(host)[2]) shl 8); HostToNEt:=HostToNet or ( (THostAddr(host)[3]) shl 16); HostToNEt:=HostToNet or ( (THostAddr(host)[4]) shl 24); end; Function NetToHost (Net : Longint) : Longint; begin NetToHost:=THostAddr(Net)[1]; NetToHost:=NetToHost or ( (THostAddr(Net)[2]) shl 8); NetToHost:=NetToHost or ( (THostAddr(Net)[3]) shl 16); NetToHost:=NetToHost or ( (THostAddr(Net)[4]) shl 24); end; Function ShortHostToNet (Host : integer) : integer; begin ShortHostToNet:=lo(host)*256+Hi(Host); end; Function ShortNetToHost (Net : integer) : integer; begin ShortNetToHost:=lo(Net)*256+Hi(Net); end; end. $Log: inet.pp,v $ Revision 1.2 2000/07/13 11:33:26 michael + removed logs } imapcopy-1.04/imapcopy.pp0000644000175000017500000000117510032507234014433 0ustar errgeerrge{********************************************************************** $Id: ImapCopy.pp This file is part of imapcopy Copyright (c) 2001..2004 Armin Diehl IMapCopy main for FreePascal This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} PROGRAM imapcopy; {$MODE Delphi} USES imapcopymain; BEGIN imapcopymain.Header; imapcopymain.ParseCommandLine; imapcopymain.Main; END. imapcopy-1.04/logfile.pas0000644000175000017500000000552210257750647014420 0ustar errgeerrge{********************************************************************** $Id: logfile.pas This file is part of imapcopy Copyright (c) 2001-2005 Armin Diehl Logging to screen or file for imapcopy This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} unit logfile; {$IFDEF FPC} {$MODE Delphi} {$ENDIF} interface {$I-} uses sysutils; const log_message = 0; log_warning = 1; log_error = 2; log_status = 4; log_fatal = 8; log_file = 16; log_to_stdout = log_message + log_status; log_to_stderr = log_warning + log_error + log_fatal; log_to_logfile = log_warning + log_error + log_status + log_fatal + log_file; log_to_file : boolean = false; log_filename : string = 'imapcopy.log'; log_file_open : boolean = false; function log_openfile (const fn : string) : boolean; function log_closefile : boolean; procedure log (logclass : integer; msg : string); procedure logfmt (logclass : integer; fmtstr : string; args : array of const); implementation var fLog : file; function log_openfile (const fn : string) : boolean; begin log_closefile; if fn <> '' then log_filename := fn; assign (fLog,log_filename); reset (fLog,1); if IOResult <> 0 then rewrite (fLog,1) else seek (fLog, filesize(fLog)); log_file_open := (IOResult = 0); result := log_file_open; end; function log_closefile : boolean; begin if log_file_open then begin close (fLog); log_file_open := (IOResult <> 0); result := not log_file_open; end else result := true; end; procedure log (logclass : integer; msg : string); var to_stdout, to_stderr, to_file : boolean; begin to_stdout := (logclass and log_to_stdout <> 0); to_stderr := (logclass and log_to_stderr <> 0); to_file := (logclass and log_to_logfile <> 0); if to_stdout then writeln (msg); if to_stderr then (*$IFDEF Delphi*) writeln (msg); // at least delphi3 has no stderr (*$ELSE*) writeln (stderr,msg); (*$ENDIF*) if to_file then if log_file_open then begin Case logclass of log_message : Msg := 'M '+Msg; log_warning : Msg := 'W '+Msg; log_error : Msg := 'E '+Msg; log_status : Msg := 'S '+Msg; log_fatal : Msg := 'F '+Msg else Msg := ' '+Msg; end; (*$IFNDEF Unix*) Msg := Msg + #13#10; (*$ELSE*) Msg := Msg + #10; (*$ENDIF*) BlockWrite (fLog,msg[1],length(msg)); end; IOResult; end; procedure logfmt (logclass : integer; fmtstr : string; args : array of const); var msg : string; begin msg := format (fmtstr, args); log (logclass, msg); end; begin log_closefile; end. imapcopy-1.04/ImapCopy.dpr0000644000175000017500000000115307335325340014505 0ustar errgeerrge{********************************************************************** $Id: ImapCopy.dpr This file is part of imapcopy Copyright (c) 2001 Armin Diehl IMapCopy main for Delphi This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} PROGRAM IMapCopy; USES ImapTools, ImapCopyMain; BEGIN ImapCopyMain.Header; ImapCopyMain.ParseCommandLine; ImapCopyMain.Main; END. imapcopy-1.04/ImapCopy.dof0000644000175000017500000000256307730327260014500 0ustar errgeerrge[Compiler] A=1 B=0 C=1 D=1 E=0 F=0 G=1 H=1 I=1 J=1 K=0 L=1 M=0 N=1 O=1 P=1 Q=0 R=0 S=0 T=0 U=0 V=1 W=0 X=1 Y=0 Z=1 ShowHints=1 ShowWarnings=1 UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; [Linker] MapFile=0 OutputObjs=0 ConsoleApp=0 DebugInfo=0 MinStackSize=16384 MaxStackSize=1048576 ImageBase=4194304 ExeDescription= [Directories] OutputDir= UnitOutputDir= SearchPath=./delphi Packages=vclx30;VCL30;vcldb30;vcldbx30;inetdb30;inet30;VclSmp30;Qrpt30;teeui30;teedb30;tee30;dss30;IBEVNT30;Tap252fr;Tap252_r;Tap252tr Conditionals= DebugSourceDirs= UsePackages=0 [Parameters] RunParams=-t HostApplication= [Version Info] IncludeVerInfo=0 AutoIncBuild=0 MajorVer=1 MinorVer=0 Release=0 Build=0 Debug=0 PreRelease=0 Special=0 Private=0 DLL=0 Locale=1031 CodePage=1252 [Version Info Keys] CompanyName= FileDescription= FileVersion=1.0.0.0 InternalName= LegalCopyright= LegalTrademarks= OriginalFilename= ProductName= ProductVersion=1.0.0.0 Comments= [Excluded Packages] C:\WINNT\System32\IBEVNT30.dpl=InterBase-Event-Alerter-Komponente M:\SDK\AsyncPro\TAp252FD.dpl=Async Professional Fax Components C:\WINNT\System32\Tap252_d.dpl=Async Professional Base Components M:\SDK\AsyncPro\TAp252TD.dpl=Async Professional TAPI Components N:\WINPRJ\Delphi32\LIB\sql40.dpl=SQL40 - Komponenten imapcopy-1.04/imaptools.pas0000664000175000017500000013051211230427275014774 0ustar errgeerrge{********************************************************************** $Id: imaptools.pas This file is part of imapcopy Copyright (c) 2001-2009 Armin Diehl simple IMAP client object Armin Diehl 2001/07/29 This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 2001/10/05: Changes for Linux 2002/01/26: Check if internaldate returned by server is correct and return nothing if date is invalid RFC822MessageDate ad 2003/07/15: minor changes for compiling with FreePascal 1.0.10 and 1.1 ad 2003/12/14: \ was not converted to \\ before sending to server on some places, needed for Notes because the path separator is \ ad 2004/05/09: Added ReadALineAndCount ad 2005/04/10: Fixed memory leak (Objects in Mailboxlist) ad 2005/06/16: Added logfile ad 2009/07/18: Added timezone conversion **********************************************************************} UNIT imaptools; {$IFDEF FPC} {$MODE Delphi} {$ENDIF} INTERFACE {$IFDEF Unix} {$LINKLIB c} {$ENDIF} USES SysUtils, {$IFDEF Win32} WinSock, {$ELSE} {$IFDEF Unix} Sockets, {$ifdef VER1_0} linux,inet, {$else} unix,baseunix,inet, {$endif} {$ELSE} Error, Unknown Opsys {$ENDIF} {$ENDIF} {enTypes,}Classes, logfile; {$ifndef delphi} {$ifndef VER1_0} {$macro on} {$define FD_SET:=fpFD_SET} {$define FD_ZERO:=fpFD_Zero} {$ENDIF} {$endif} CONST ReadBufferSizeK = 32768; TYPE {$IFDEF Unix} TSocket = LONGINT; {$ENDIF} IMapServer = CLASS (TObject) ServSock : TSocket; State : (sDisconnected,sConnected,sLoggedin); LastResult : STRING; SeqNo : LONGINT; Response : TStringList; NumMessages : INTEGER; NumMessagesUnseen : INTEGER; MailboxList : TStringList; {MessageList : TList; // UID's of all Messages } CurrentMailbox : STRING; PathSep : STRING; ReadBuf : ARRAY [1..ReadBufferSizeK] OF CHAR; ReadBufPos : INTEGER; ReadBufLen : INTEGER; LastMessageLen : INTEGER; Capabilities : STRING; ServerInfo : STRING; NamespaceUser : STRING; NamespaceOtherUser : STRING; NamespacePublicFolders: STRING; DebugCommands : BOOLEAN; ImapUser,ImapPwd, IMapServer : STRING; IMapPort : WORD; LogoutInProgess : BOOLEAN; CONSTRUCTOR Create; DESTRUCTOR Destroy; OVERRIDE; PROCEDURE FlushInBuffer; FUNCTION ReadAChar (VAR C : CHAR; Timeout : INTEGER) : INTEGER; FUNCTION ReadALineAndCount (VAR Line : STRING; Timeout : INTEGER; VAR ByteCount : CARDINAL; MaxLen : CARDINAL) : INTEGER; FUNCTION ReadALine (VAR Line : STRING; Timeout : INTEGER) : INTEGER; FUNCTION Command (Cmd : STRING; AcceptLen : BOOLEAN) : INTEGER; FUNCTION Connect (Host : STRING; Port : WORD) : INTEGER; FUNCTION Login (User,Password : STRING) : INTEGER; FUNCTION Logout : INTEGER; FUNCTION GetCapabilities : STRING; FUNCTION GetNamespaces : STRING; FUNCTION SelectMailbox (Mailbox : STRING) : INTEGER; FUNCTION CreateMailbox (Mailbox : STRING) : INTEGER; FUNCTION SubscribeMailbox(Mailbox : STRING) : INTEGER; PROCEDURE ClearMailboxList; FUNCTION GetMailboxList : INTEGER; // Result in MailboxList //FUNCTION FetchUIDS : INTEGER; // Gets all UIDS of current selected mailbox (in MessageList) //FUNCTION UID (MessageNumber : INTEGER) : CARDINAL; FUNCTION MessageSubject (MessageNumber : INTEGER) : STRING; FUNCTION MessageFrom (MessageNumber : INTEGER) : STRING; FUNCTION MessageBody (MessageNumber : INTEGER) : STRING; FUNCTION MessageFlags (MessageNumber : INTEGER) : STRING; FUNCTION MessageDate (MessageNumber : INTEGER) : STRING; FUNCTION RFC822MessageDate (MessageNumber : INTEGER) : STRING; // special for Lotus Notes FUNCTION MessageSave (Mailbox, Msg, Flags, Internaldate : STRING) : INTEGER; FUNCTION RemovePersonalNamespace (FolderName : STRING) : STRING; FUNCTION isOtherUsersFoler (FolderName : STRING) : BOOLEAN; FUNCTION isPublicFolder (FolderName : STRING) : BOOLEAN; END; { \Noinferiors It is not possible for any child levels of hierarchy to exist under this name; no child levels exist now and none can be created in the future. \Noselect It is not possible to use this name as a selectable mailbox. \Marked The mailbox has been marked "interesting" by the server; the mailbox probably contains messages that have been added since the last time the mailbox was selected. \Unmarked The mailbox does not contain any additional messages since the last time the mailbox was selected. } TMailbox = CLASS (TObject) // Object with additional info for StringList "MailboxList" Flags : STRING; Noinferiors : BOOLEAN; Noselect : BOOLEAN; Marked : BOOLEAN; Unmarked : BOOLEAN; HasChildren : BOOLEAN; CONSTRUCTOR Create (Flgs : STRING); END; CONST ImapOK = 0; ImapErr = -1; ImapErrInvalidStateK = $FFFF; CRLF : STRING [2] = #13#10; PROCEDURE DelGarbage (VAR S : STRING); FUNCTION NextWord (VAR S : STRING) : STRING; FUNCTION TCPConnectTo (VAR aSocket : TSocket; AdressOrName : PCHAR; Port : WORD) : INTEGER; PROCEDURE AddTimeZoneConversionEntry (ZoneAsText,ZoneAsImapOffset : STRING); // e.g. 'UTC','+0000' IMPLEMENTATION CONST ImapPortK = 143; StdTimeoutK = 30; // Seconds per character {$IFDEF Win32} VAR Initialized: Boolean = False; InitData : TWSAData; {$ENDIF} VAR TimeZoneTable : TStringList; {$IFDEF Unix} FUNCTION WSAGetLastError : LONGINT; BEGIN Result := errno; END; PROCEDURE closesocket (Socket : TSocket); BEGIN {$ifdef VER1_0} fdClose (Socket); {$else} fpclose (Socket); {$endif} END; {$ENDIF} FUNCTION TCPConnectTo (VAR aSocket : TSocket; AdressOrName : PCHAR; Port : WORD) : INTEGER; {$IFDEF Unix} VAR Addr : TInetSockAddr; Host : THost; BEGIN Host.NameLookup (AdressOrName); IF Host.LastError <> 0 THEN BEGIN {WriteLn ('Host lookup (',AdressOrName,') failed');} Result := 1; EXIT; END; Addr.family := AF_INET; Addr.port := ShortHostToNet (Port); {WriteLn ('IP: ',hostaddrtostr (Host.IPAddress));} Addr.addr := HostToNet (LONGINT (Host.IPAddress)); aSocket := Socket(AF_INET,SOCK_STREAM,0); IF NOT Sockets.Connect (aSocket,ADDR,SIZEOF(ADDR)) THEN BEGIN Result := errno; IF errno = 0 THEN Result:= 1; END ELSE BEGIN Result := 0; {WriteLn ('Connected errno:',errno,' Socket: ',aSocket);} END; END; {$ELSE} VAR Remote_Addr : TSockAddrIn; Remote_Host : Phostent; A : TInAddr; OptVal : INTEGER; BEGIN FillChar (Remote_Addr, SIZEOF(Remote_Addr), 0); FillChar (Remote_Host, SIZEOF (Remote_Host), 0); Remote_Addr.sin_addr.S_addr := 0; // try to convert to address u_long (A) := inet_addr (AdressOrName); IF u_long (A) = u_long (INADDR_NONE) THEN BEGIN // may be a hostname Remote_Host := gethostbyname(AdressOrName); IF Remote_Host <> NIL THEN BEGIN Remote_Addr.sin_addr := PInAddr(Remote_Host^.h_addr_list^)^; END; END ELSE Remote_Addr.sin_addr.S_addr := u_long (A); Remote_Addr.sin_family := PF_INET; Remote_Addr.sin_port := htons (Port); // Ok, Host known, get socket IF Remote_Addr.sin_addr.S_addr = 0 THEN BEGIN Result := WSAGetLastError; IF Result = 0 THEN Result := 1; aSocket := TSocket (INVALID_SOCKET); EXIT; END ELSE aSocket := socket(PF_INET, SOCK_STREAM, IPPROTO_IP); IF aSocket = TSocket (INVALID_SOCKET) THEN BEGIN Result := WSAGetLastError; IF Result = 0 THEN Result := 2; EXIT; END; IF connect (aSocket, Remote_Addr, SIZEOF (Remote_Addr)) <> 0 THEN BEGIN closesocket (aSocket); Result := WSAGetLastError; aSocket := TSocket (INVALID_SOCKET); IF Result = 0 THEN Result := 3; EXIT; END; OptVal := 1; setsockopt (aSocket, IPPROTO_TCP, TCP_NODELAY, PChar (@OptVal), SIZEOF(OptVal)); Result := 0; END; {$ENDIF} PROCEDURE ImapServer.FlushInBuffer; VAR Skipped : STRING; C : CHAR; P : INTEGER; BEGIN Skipped := ''; WHILE ReadBufPos <= ReadBufLen DO BEGIN Skipped := Skipped + ReadBuf[ReadBufPos]; INC (ReadBufPos); END; WHILE (ReadAChar (C, -1) = 0) DO Skipped := Skipped + C; IF Skipped <> '' THEN BEGIN P := Pos (#13,Skipped); WHILE (P > 0) DO BEGIN Delete (Skipped,P,1); Insert ('\r',Skipped,P); P := Pos (#13,Skipped); END; P := Pos (#10,Skipped); WHILE (P > 0) DO BEGIN Delete (Skipped,P,1); Insert ('\n',Skipped,P); P := Pos (#10,Skipped); END; WriteLn ('Skipped: "',Skipped,'"'); END; END; FUNCTION ImapServer.ReadAChar (VAR C : CHAR; Timeout : INTEGER) : INTEGER; VAR readfds: TFDSet; FA: TTimeVal; Err: Integer; {$ifdef debug} {$ifdef WIN32} Len : integer; {$endif} {$endif} BEGIN IF ReadBufPos <= ReadBufLen THEN BEGIN C := ReadBuf[ReadBufPos]; INC (ReadBufPos); Result := 0; EXIT; END; ReadBufPos := 1; ReadBufLen := 0; FillChar (FA, SizeOf (FA), 0); IF Timeout = -1 THEN BEGIN {$IFDEF Unix} {$IFDEF VER1_0} FA.sec := 0; FA.usec:= 0; {$ELSE} FA.tv_sec := 0; FA.tv_usec:= 0; {$ENDIF} {$ELSE} FA.tv_sec := 0; FA.tv_usec:= 0; {$ENDIF} END ELSE BEGIN {$IFDEF Unix} {$ifdef VER1_0} FA.sec := Timeout; IF Timeout = 0 THEN FA.usec:= 1000 ELSE FA.usec:= 0; {$else} FA.tv_sec := Timeout; IF Timeout = 0 THEN FA.tv_usec:= 1000 ELSE FA.tv_usec:= 0; {$endif} {$ELSE} FA.tv_sec := Timeout; IF Timeout = 0 THEN FA.tv_usec:= 1000 ELSE FA.tv_usec:= 0; {$ENDIF} END; {$IFDEF Unix} FD_Zero (readfds); FD_Set (ServSock, readfds); {$ELSE} readfds.fd_count:= 1; readfds.fd_array[0] := ServSock; {$ENDIF} {$IFDEF Win32} Err := Select (0, // nfds ignored on Win32 {$ELSE} Err := {$ifdef VER1_0}linux.Select{$else}baseunix.FPSelect{$endif} (ServSock+1, {$ENDIF} @readfds, NIL, // @readfds, // writefds NIL, // @readfds, // exceptfds @FA); IF Err > 0 THEN BEGIN ReadBufLen := Recv (ServSock, ReadBuf, SIZEOF(ReadBuf), 0); IF ReadBufLen > 0 THEN Result := ReadAChar (C, 0) ELSE BEGIN {$IFDEF DEBUG} {$ifdef WIN32} IF Len = SOCKET_ERROR THEN DbgProc ('ReadAChar: Recv() returned SOCKET_ERROR (%d)', [WSAGetLastError]) ELSE DbgProc ('ReadAChar: Recv() returned: %d', [Len]); {$ENDIF} {$ENDIF} Result := WSAGetLastError; IF Result = 0 THEN INC (Result); END; END ELSE BEGIN {$IFDEF DEBUG} {$IFDEF WIN32} IF Err = SOCKET_ERROR THEN DbgProc ('ReadAChar: Select() returned SOCKET_ERROR (%d)', [WSAGetLastError]) ELSE DbgProc ('ReadAChar: Select() returned: %d', [Err]); {$ENDIF} {$ENDIF} Result := WSAGetLastError; IF Result = 0 THEN INC (Result); END; END; FUNCTION ImapServer.ReadALineAndCount (VAR Line : STRING; Timeout : INTEGER; VAR ByteCount : CARDINAL; MaxLen : CARDINAL) : INTEGER; VAR C : CHAR; S : STRING; P : INTEGER; BEGIN C := #0; Result := ReadAChar (C, Timeout); S := ''; IF Result <> 0 THEN EXIT; Line := ''; WHILE (Result = 0) AND (C <> #10) DO BEGIN IF (C <> #13) THEN BEGIN IF C = #0 THEN // Ignore #0 in Messages, i.e. the ipswitch imap dont like #0 C := ' '; Line := Line + C; END; S := S + C; inc (ByteCount); IF MaxLen > 0 then IF ByteCount >= MaxLen then break; Result := ReadAChar (C, Timeout); END; IF Result = 0 THEN begin S := S + C; inc (ByteCount); end; IF DebugCommands THEN BEGIN P := Pos (#13,S); WHILE (P > 0) DO BEGIN Delete (S,P,1); Insert ('\r',S,P); P := Pos (#13,S); END; P := Pos (#10,S); WHILE (P > 0) DO BEGIN Delete (S,P,1); Insert ('\n',S,P); P := Pos (#10,S); END; WriteLn (#13'R:',S); END; END; FUNCTION ImapServer.ReadALine (VAR Line : STRING; Timeout : INTEGER) : INTEGER; VAR Dummy : CARDINAL; BEGIN Dummy := 0; Result := ReadALineAndCount (Line, Timeout, Dummy, 0); END; { rfc2060: All interactions transmitted by client and server are in the form of lines; that is, strings that end with a CRLF. The protocol receiver of an IMAP4rev1 client or server is either reading a line, or is reading a sequence of octets with a known count followed by a line. } FUNCTION WriteALine (Socket : TSocket; Txt : STRING; DebugCommands: BOOLEAN) : INTEGER; VAR P : INTEGER; S : STRING; BEGIN Result := {$IFDEF Win32}WinSock.{$ENDIF}send (Socket, PChar(Txt)^, Length (Txt), 0); IF Result = Length (Txt) THEN Result := 0; IF DebugCommands THEN BEGIN S := Txt; P := Pos (#13,S); WHILE (P > 0) DO BEGIN Delete (S,P,1); Insert ('\r',S,P); P := Pos (#13,S); END; P := Pos (#10,S); WHILE (P > 0) DO BEGIN Delete (S,P,1); Insert ('\n',S,P); P := Pos (#10,S); END; WriteLn (#13,'S:',S); END; IF Result <> 0 THEN BEGIN Result := WSAGetLastError; IF DebugCommands THEN WriteLn ('Error WSA'+IntToStr(Result)+' sending line to server'); END; END; //----------------------------------------------------------------------------- FUNCTION QuoteSpecialChars (S : STRING) : STRING; BEGIN Result := S; END; FUNCTION DecodeCString (S : STRING) : STRING; VAR P : PCHAR; BEGIN Result := ''; P := PChar (S); WHILE P^ <> #0 DO BEGIN IF P^ = '\' THEN BEGIN INC (P); CASE P^ OF #0 : ; 'n' : Result := Result + #13; 'r' : Result := Result + #10; 't' : Result := Result + #9 ELSE Result := Result + P^; END; IF P^ <> #0 THEN INC (P); END ELSE BEGIN Result := Result + P^; INC (P); END; END; END; FUNCTION CodeCStr (S : STRING) : STRING; VAR I : INTEGER; BEGIN Result := ''; FOR I := 1 TO Length (S) DO BEGIN Result := Result + S[i]; IF S[i] = '\' THEN Result := Result + '\'; END; END; FUNCTION SetQuotationMarksIfNeeded (S : STRING) : STRING; BEGIN IF Pos (' ', S) > 0 THEN Result := '"' + CodeCStr (S) + '"' ELSE BEGIN Result := CodeCStr (S); // Notes wants to have Strings containing \\ in Quotaion Marks !! IF (Pos ('\\',Result) <> 0) THEN Result := '"' + Result + '"'; END; END; PROCEDURE GetListResults (Line : STRING; VAR Flags, PathSeparator, Name : STRING); BEGIN // * LIST (\HasNoChildren) "." "INBOX.Archiv-Diverses" // * LIST () "/" foo/bar Flags := ''; PathSeparator := ''; Name := ''; IF NextWord (Line) <> '*' THEN EXIT; IF UpperCase (NextWord (Line)) <> 'LIST' THEN EXIT; Flags := NextWord (Line); PathSeparator := NextWord (Line); PathSeparator := DecodeCString (PathSeparator); // i.e. for notes imap -> "\\" Name := NextWord (Line); END; CONSTRUCTOR ImapServer.Create; BEGIN INHERITED Create; Response := TStringList.Create; MailboxList := TStringList.Create; //MessageList := TList.Create; NumMessages := 0; SeqNo := 1; State := sDisconnected; CurrentMailbox := ''; ReadBufLen := 0; ReadBufPos := 1; NamespaceUser := ''; NamespaceOtherUser := ''; NamespacePublicFolders:= ''; ServerInfo := ''; DebugCommands := FALSE; LogoutInProgess := FALSE; END; DESTRUCTOR ImapServer.Destroy; BEGIN IF State > sDisconnected THEN Logout; IF State >= sConnected THEN closesocket (ServSock); Response.Free; ClearMailboxList; MailboxList.Free; //MessageList.Free; END; FUNCTION ImapServer.Command (Cmd : STRING; AcceptLen : BOOLEAN) : INTEGER; VAR Line : STRING; Seq : STRING; First : BOOLEAN; P : PCHAR; LenStr : STRING; Received : CARDINAL; IgnoreRest : BOOLEAN; BEGIN Response.Clear; LastMessageLen := 0; Seq := 'A' + IntToHex (SeqNo,4) + ' '; INC (SeqNo); IF SeqNo > $FFFF THEN SeqNo := 1; Line := Seq + Cmd + CRLF; Result := WriteALine (ServSock, Line, DebugCommands); IF Result <> 0 THEN BEGIN IF NOT LogoutInProgess THEN BEGIN log (log_error,'Error '+IntToStr(Result)+' sending line to server, connection lost ?'); IF IMapServer <> '' THEN BEGIN Write ('Trying to reconnect to ',IMapServer,' '); closesocket (ServSock); IF Connect (IMapServer, IMapPort) = 0 THEN BEGIN IF Login (IMapUser,IMapPwd) = 0 THEN BEGIN log (log_message,'Reconnect/Login OK'); IF CurrentMailbox <> '' THEN IF SelectMailbox (CurrentMailbox) <> 0 THEN BEGIN log (log_error, 'Select Mailbox "'+CurrentMailbox+'" after reconnect failed'); EXIT; END; FlushInBuffer; Result := WriteALine (ServSock, Line, DebugCommands); IF Result <> 0 THEN BEGIN log (log_error, 'Error '+IntToStr(Result)+' sending line to server, connection lost ?'); EXIT; END; END ELSE BEGIN log (log_error, 'LOGIN as "'+IMapUser+'" FAILED'); EXIT; END; END ELSE BEGIN Write (#13); log (log_error,'Reconnect to Server '+IMapServer+' failed'); IMapServer := ''; END; END; END; EXIT; END; // Read Results until a line begins with Seq LastResult := ''; First := TRUE; IgnoreRest := FALSE; REPEAT Result := ReadALine (Line, StdTimeoutK); IF First THEN BEGIN IF AcceptLen THEN BEGIN IF (Result = 0) AND (Copy (Line,1,1) = '*') AND (Line[Length(Line)] = '}') THEN BEGIN // Server sends length of data LenStr := ''; P := @Line[Length(Line)-1]; WHILE P^ <> '{' DO BEGIN LenStr := P^ + LenStr; DEC (P); END; LastMessageLen := StrToInt (LenStr); //WriteLn ('Got Len: ',LastMessageLen); Received := 0; //Response.Add (Line); Result := ReadALineAndCount (Line, StdTimeoutK, Received, LastMessageLen); WHILE (Result = 0) AND (Received < LastMessageLen) DO BEGIN Response.Add (Line); //INC (Received, Length (Line) + Length (CRLF)); IF (Received < LastMessageLen) THEN Result := ReadALineAndCount (Line, StdTimeoutK, Received, LastMessageLen) ELSE BEGIN Line := ''; IgnoreRest := TRUE; END; END; Response.Add (Line); //Kasper 2007-03-14: Store last line IgnoreRest := true; END; END; END; IF (Result = 0) AND (Copy (Line,1,1) = '+') THEN BEGIN IF DebugCommands THEN WriteLn ('C: Command exit because of + ("'+Line+'")'); EXIT; // i.e. for APPEND END; First := FALSE; IF Result = 0 THEN IF NOT IgnoreRest THEN Response.Add (Line); UNTIL (Result <> 0) OR (Copy (Line,1,Length(Seq)) = Seq); IF Result = 0 THEN BEGIN LastResult := Copy (Line,Length(Seq)+1,Length(Line)); WHILE (Length (LastResult) > 0) AND (Copy (LastResult,1,1) <= ' ') DO Delete (LastResult,1,1); IF UpperCase (Copy(LastResult,1,2)) <> 'OK' THEN Result := ImapErr; END ELSE BEGIN IF DebugCommands THEN WriteLn ('C: Command status '+IntToStr(Result)); END; END; FUNCTION ImapServer.Connect (Host : STRING; Port : WORD) : INTEGER; BEGIN IF Port = 0 THEN Port := ImapPortK; Result := TCPConnectTo (ServSock, PChar (Host), Port); IF Result = 0 THEN BEGIN State := sConnected; Result := ReadALine (ServerInfo, StdTimeoutK); NextWord (ServerInfo); // * NextWord (ServerInfo); // OK IMapServer := Host; IMapPort := Port; ReadBufPos := 1; ReadBufLen := 0; END; END; FUNCTION DecodeNamespaces ( NS : STRING; VAR NSUser, NSotherUser, NSPublic, SepUser, SepOtherUser, SepPublic : STRING) : BOOLEAN; VAR S : STRING; BEGIN NSUser := ''; NSotherUser := ''; NSPublic := ''; SepUser := ''; SepOtherUser := ''; SepPublic := ''; NextWord (NS); S := UpperCase (NextWord (NS)); Result := FALSE; IF S <> 'NAMESPACE' THEN EXIT; S := NextWord (NS); IF UpperCase (S) <> 'NIL' THEN BEGIN S := NextWord (S); // remove () NSUser := NextWord (S); SepUser := DecodeCString (NextWord (S)); // AD 2003/11/04 for Notes IF (NSUser <> '') AND (SepUser <> '') THEN IF Copy (NSUser,Length(NSUser)-Length(SepUser)+1,Length(SepUser)) = SepUser THEN NSUser := Copy (NSUser,1,Length(NSUser)-Length(SepUser)); END; S := NextWord (NS); IF UpperCase (S) <> 'NIL' THEN BEGIN S := NextWord (S); // remove () NSOtherUser := NextWord (S); SepOtherUser := DecodeCString (NextWord (S)); // AD 2003/11/04 for Notes IF (NSOtherUser <> '') AND (SepOtherUser <> '') THEN IF Copy (NSOtherUser,Length(NSOtherUser)-Length(SepOtherUser)+1,Length(SepOtherUser)) = SepOtherUser THEN NSOtherUser := Copy (NSOtherUser,1,Length(NSOtherUser)-Length(SepOtherUser)); END; S := NextWord (NS); IF UpperCase (S) <> 'NIL' THEN BEGIN S := NextWord (S); // remove () NSPublic := NextWord (S); SepPublic := DecodeCString (NextWord (S)); // AD 2003/11/04 for Notes IF (NSPublic <> '') AND (SepPublic <> '') THEN IF Copy (NSPublic,Length(NSPublic)-Length(SepPublic)+1,Length(SepPublic)) = SepPublic THEN NSPublic := Copy (NSPublic,1,Length(NSPublic)-Length(SepPublic)); END; Result := TRUE; END; FUNCTION ImapServer.Login (User,Password : STRING) : INTEGER; VAR S : STRING; NamespaceOk : BOOLEAN; BEGIN IF State <> sConnected THEN BEGIN Result := ImapErrInvalidStateK; EXIT; END; Result := Command ('LOGIN '+SetQuotationMarksIfNeeded (QuoteSpecialChars(User))+ ' '+SetQuotationMarksIfNeeded (QuoteSpecialChars(Password)),TRUE); IF Result = 0 THEN BEGIN IMapUser := User; IMapPwd := Password; NamespaceUser := ''; Capabilities := UpperCase (GetCapabilities); NamespaceOk := FALSE; IF Pos (' NAMESPACE', Capabilities) > 0 THEN BEGIN S := GetNamespaces; IF DecodeNamespaces (S,NamespaceUser,NamespaceOtherUser,NamespacePublicFolders,PathSep,S,S) THEN BEGIN IF PathSep <> '' THEN NamespaceOk := TRUE ELSE log (log_error,'Server error: NAMESPACE returned no path sepearator for personal namespace ?'); END ELSE log (log_warning, 'Ops: Server said NAMESPACE is supported but NAMESPACE command failed'); END; IF NOT NamespaceOk THEN BEGIN // determine path seperator from INBOX Result := Command ('LIST "" INBOX',FALSE); IF Result = 0 THEN BEGIN IF Response.Count > 0 THEN BEGIN GetListResults (Response[0],S,PathSep, S); IF DebugCommands THEN WriteLn ('Path Seperator >',PathSep,'<'); END ELSE BEGIN log (log_error, 'Unable to determine Path seperator'); Result := -1; END; END; END; END; FlushInBuffer; END; FUNCTION ImapServer.Logout : INTEGER; BEGIN TRY LogoutInProgess := TRUE; Result := Command ('LOGOUT',TRUE); IF Result = 0 THEN State := sConnected; FlushInBuffer; FINALLY LogoutInProgess := FALSE; END; END; FUNCTION ImapServer.GetCapabilities : STRING; BEGIN IF Command ('CAPABILITY',TRUE) = 0 THEN BEGIN Result:= Response[0]; NextWord (Result); // * NextWord (Result); // CAPABILITY END ELSE Result := ''; END; FUNCTION ImapServer.GetNamespaces : STRING; BEGIN IF Command ('NAMESPACE',TRUE) = 0 THEN Result:= Response[0] ELSE Result := ''; END; FUNCTION ImapServer.SelectMailbox (Mailbox : STRING) : INTEGER; VAR S,Keyword,Count : STRING; I : INTEGER; BEGIN NumMessages := 0; NumMessagesUnseen := 0; CurrentMailbox := ''; Result := Command ('SELECT '+SetQuotationMarksIfNeeded (Mailbox),TRUE); IF Result = 0 THEN BEGIN CurrentMailbox := Mailbox; IF Response.Count > 0 THEN FOR I := 0 TO Response.Count-1 DO BEGIN S := Response [I]; IF (NextWord (S) = '*') THEN BEGIN Count := NextWord (S); Keyword := UpperCase (NextWord (S)); IF Keyword = 'EXISTS' THEN BEGIN TRY NumMessages := StrToInt (Count); EXCEPT NumMessages := 0; log (log_error, 'Error: Server returned non numeric response before EXISTS ("'+Response [I]+'"'); END; END ELSE IF Keyword = 'RECENT' THEN BEGIN TRY NumMessagesUnseen := StrToInt (Count); EXCEPT NumMessagesUnseen := 0; log (log_error, 'Error: Server returned non numeric response before RECENT ("'+Response [I]+'"'); END; END; END; END; END; FlushInBuffer; END; FUNCTION ImapServer.SubscribeMailbox (Mailbox : STRING) : INTEGER; BEGIN Result := Command ('SUBSCRIBE '+SetQuotationMarksIfNeeded (Mailbox),TRUE); FlushInBuffer; END; FUNCTION ImapServer.CreateMailbox (Mailbox : STRING) : INTEGER; BEGIN Result := Command ('CREATE '+SetQuotationMarksIfNeeded (Mailbox),TRUE); FlushInBuffer; END; PROCEDURE DelGarbage (VAR S : STRING); BEGIN WHILE (Length (S) > 0) AND (Copy (S,1,1) <= ' ') DO Delete (S,1,1); END; PROCEDURE SucheKlZu (CONST S : STRING; VAR P : INTEGER); BEGIN IF S[P] <> '(' THEN EXIT; INC (P); WHILE (P <= Length (S)) AND (S[P] <> ')') DO BEGIN IF S[P] = '"' THEN BEGIN INC (P); WHILE (P <= Length(S)) AND (S[P] <> '"') DO INC (P); END; IF S[P] = '(' THEN SucheKlZu (S,P); INC (P); END; END; FUNCTION NextWord (VAR S : STRING) : STRING; VAR P : INTEGER; BEGIN DelGarbage (S); IF Length (S) = 0 THEN BEGIN Result := S; EXIT; END; IF S[1] = '(' THEN BEGIN P := 1; SucheKlZu (S,P); Result := Copy (S,2,P-2); Delete (S,1,P); END ELSE IF S[1] = '"' THEN BEGIN P := 2; WHILE (P <= Length (S)) AND (S[P] <> '"') DO INC (P); Result := Copy (S,2,P-2); Delete (S,1,P); END ELSE BEGIN P := Pos (' ', S); IF P = 0 THEN BEGIN Result := S; S := ''; END ELSE BEGIN Result := Copy (S,1,P-1); Delete (S,1,P); END; END; END; PROCEDURE ImapServer.ClearMailboxList; VAR I : INTEGER; BEGIN IF Mailboxlist.Count > 0 then begin for i := 0 to Mailboxlist.Count-1 do begin TMailbox (Mailboxlist.Objects[i]).Free; Mailboxlist.Objects[i] := nil; end; Mailboxlist.Clear; end; END; FUNCTION ImapServer.GetMailboxList : INTEGER; // Result in MailboxList VAR Flags, PathSeparator, Name, S : STRING; I,ListPos : INTEGER; BEGIN //MailboxList.Clear; ClearMailboxList; Flags := ''; PathSeparator := ''; Result := Command ('LIST "" *',FALSE); IF Result = 0 THEN IF Response.Count > 0 THEN BEGIN // This is a hack for lotus notes, notes sends {len} in list responses also I := 0; WHILE (I < Response.Count) DO BEGIN Name := Response[I]; IF (Copy (Name,1,1) = '*') AND (Name[Length(Name)] = '}') AND (I < Response.Count-1) THEN BEGIN WHILE (Name <> '') AND (Name[Length(Name)] <> '{') DO Name := Copy (Name,1,Length(Name)-1); IF Name <> '' THEN Name := Copy (Name,1,Length(Name)-1); INC (I); S := Response[I]; IF Pos (' ', S) > 0 THEN // AD 2003/12/14 S := '"' + S + '"'; Name := Name + ' ' + S; Response[I-1] := Name; Response.Delete (I); END ELSE INC (I); END; FOR I := 0 TO Response.Count-1 DO BEGIN GetListResults (Response[I], Flags, PathSeparator, Name); IF Copy (Name,1,1) = '"' THEN Name := Copy (Name,2,Length(Name)-2); IF Name <> '' THEN BEGIN ListPos := MailboxList.Add (Name); Mailboxlist.Objects[ListPos] := TMailbox.Create (Flags); END; END; END; END; {-- FUNCTION ImapServer.FetchUIDS : INTEGER; // Gets all UIDS of current selected mailbox (in MessageList) VAR S : STRING; UID : CARDINAL; I : INTEGER; BEGIN MessageList.Clear; Result := Command ('UID FETCH 1:* (UID)'); IF Result = 0 THEN IF Response.Count > 0 THEN FOR I := 0 TO Response.Count-1 DO BEGIN S := Response[I]; IF NextWord (S) = '*' THEN BEGIN NextWord (S); // Message Number IF UpperCase (NextWord (S)) = 'FETCH' THEN BEGIN S := NextWord (S); // UID xxxx DelGarbage (S); IF UpperCase (Copy (S,1,3)) = 'UID' THEN BEGIN Delete (S,1,3); DelGarbage (S); UID := StrToInt (S); // FIXME: StrToInt returns integer, we need cardinal MessageList.Add (POINTER (UID)); END; END; END; END; NumMessages := MessageList.Count; END; FUNCTION ImapServer.UID (MessageNumber : INTEGER) : CARDINAL; BEGIN IF (MessageNumber < 1) OR (MessageNumber > NumMessages) THEN Result := 0 ELSE Result := CARDINAL (MessageList[MessageNumber-1]); END; --} FUNCTION ImapServer.MessageSubject (MessageNumber : INTEGER) : STRING; BEGIN Result := ''; IF MessageNumber > 0 THEN BEGIN IF Command ('FETCH '+IntToStr(MessageNumber)+' (BODY[HEADER.FIELDS (Subject)])',TRUE) = 0 THEN BEGIN IF Response.Count > 0 THEN Result := Copy (Response[0],10,512); END; END; END; FUNCTION ImapServer.MessageFrom (MessageNumber : INTEGER) : STRING; BEGIN Result := ''; IF MessageNumber > 0 THEN BEGIN IF Command ('FETCH '+IntToStr(MessageNumber)+' (BODY[HEADER.FIELDS (From)])',TRUE) = 0 THEN BEGIN IF Response.Count > 0 THEN Result := Copy (Response[0],7,512); END; END; END; FUNCTION ImapServer.MessageBody (MessageNumber : INTEGER) : STRING; VAR TotalLen,L,U : CARDINAL; P : PCHAR; BEGIN IF Response.Capacity < 655535 THEN Response.Capacity := 65535; Result := ''; IF MessageNumber > 0 THEN BEGIN // IF Command ('FETCH '+IntToStr(MessageNumber)+' (BODY[])',TRUE) = 0 THEN IF Command ('FETCH '+IntToStr(MessageNumber)+' (BODY.PEEK[])',TRUE) = 0 THEN BEGIN IF Response.Count > 0 THEN BEGIN TotalLen := 0; FOR U := 0 TO Response.Count-1 DO BEGIN INC (TotalLen, Length (Response[U])); INC (TotalLen,2); // CRLF END; SetLength (Result, TotalLen); {Result := ''; FOR U := 0 TO Response.Count-1 DO Result := Result + Response [U] + CRLF;} // This is horrible slow on large messages using delphi3 !! P := PChar (Result); FOR U := 0 TO Response.Count-1 DO BEGIN L := Length (Response[U]); Move (PChar(Response[U])^, P^, L); INC (P, L); Move (CRLF[1], P^, 2); INC (P, 2); END; END; END; FlushInBuffer; END; END; FUNCTION ImapServer.MessageFlags (MessageNumber : INTEGER) : STRING; VAR S : STRING; U : INTEGER; BEGIN Result := ''; IF MessageNumber > 0 THEN BEGIN IF Command ('FETCH '+IntToStr(MessageNumber)+' (FLAGS)',TRUE) = 0 THEN BEGIN IF Response.Count > 0 THEN FOR U := 0 TO Response.Count-1 DO BEGIN S := Response [U]; IF NextWord (S) = '*' THEN BEGIN NextWord (S); IF UpperCase (NextWord (S)) = 'FETCH' THEN BEGIN S := NextWord (S); // FLAGS (\bla \bla) IF UpperCase (NextWord(S)) = 'FLAGS' THEN BEGIN Result := NextWord (S); EXIT; END; END; END; END; END; FlushInBuffer; END; END; { i.e. 05-Jul-2001 10:03:50 +0200 } FUNCTION MessageDateValid (VAR OrgMsgDateTime : STRING) : BOOLEAN; VAR I, J : INTEGER; ValidMonth : STRING; MsgDateTime : STRING; st : STRING; BEGIN Result := FALSE; //OrgMsgDateTime := copy(OrgMsgDateTime,1,20) + ' UT'; // TEST MsgDateTime := OrgMsgDateTime; {day} I := Pos ('-', MsgDateTime); IF I < 2 THEN EXIT; IF I = 2 THEN OrgMsgDateTime := '0' + OrgMsgDateTime; { ad 2003/11/21: Insert a 0 if day in date is one digit } J := 0; TRY J := StrToInt (Copy (MsgDateTime,1,I-1)); EXCEPT END; IF (J < 1) OR (J > 31) THEN EXIT; Delete (MsgDateTime,1,I); {month} ValidMonth := 'JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC,'; I := Pos ('-', MsgDateTime); IF I < 4 THEN EXIT; J := Pos (AnsiUpperCase (Copy (MsgDateTime,1,I-1))+',', ValidMonth); IF J = 0 THEN EXIT; Delete (MsgDateTime,1,I); {year} I := Pos (' ', MsgDateTime); IF I < 3 THEN EXIT; J := 0; TRY J := StrToInt (Copy (MsgDateTime,1,I-1)); EXCEPT END; IF J = 0 THEN EXIT; // not sure, is a 2 digit year allowed ? IF (J < 100) AND (J > -1) THEN IF J > 50 THEN INC (J,1900) ELSE INC (J,2000); // We allow 1970 to 2200 as valid years here IF (J < 1970) OR (J > 2200) THEN EXIT; Delete (MsgDateTime,1,I); {hour} I := Pos (':', MsgDateTime); IF I < 3 THEN EXIT; J := -1; TRY J := StrToInt (Copy (MsgDateTime,1,I-1)); EXCEPT END; IF (J < 0) OR (J > 23) THEN EXIT; Delete (MsgDateTime,1,I); {Minute} I := Pos (':', MsgDateTime); IF I < 3 THEN EXIT; J := -1; TRY J := StrToInt (Copy (MsgDateTime,1,I-1)); EXCEPT END; IF (J < 0) OR (J > 59) THEN EXIT; Delete (MsgDateTime,1,I); {Second} I := Pos (' ', MsgDateTime); IF I < 3 THEN EXIT; J := -1; TRY J := StrToInt (Copy (MsgDateTime,1,I-1)); EXCEPT END; IF (J < 0) OR (J > 59) THEN EXIT; Delete (MsgDateTime,1,I); {offset +0000 -0000} MsgDateTime := Trim(MsgDateTime); // in case we have something like "+0000 (GMT)" remove the (... I := Pos (' ',MsgDateTime); IF (I > 0) then delete (MsgDateTime,I,255); // check if we have a conversion entry st := TimeZoneTable.Values [MsgDateTime]; IF st <> '' THEN BEGIN MsgDateTime := OrgMsgDateTime; OrgMsgDateTime := copy(OrgMsgDateTime,1,20)+' '+st; //WriteLn ('** converted timezone from "'+MsgDateTime+'" to "'+OrgMsgDateTime+'"'); END; Result := TRUE; END; FUNCTION ImapServer.RFC822MessageDate (MessageNumber : INTEGER) : STRING; VAR U : CARDINAL; S,S2 : STRING; I, J : INTEGER; Resu, Validmonth : STRING; BEGIN Result := ''; U := MessageNumber; // UID (MessageNumber); IF U > 0 THEN BEGIN IF Command ('FETCH '+IntToStr(U)+' (BODY[HEADER.FIELDS (DATE)])',TRUE) = 0 THEN BEGIN IF Response.Count > 0 THEN FOR U := 0 TO Response.Count-1 DO BEGIN S := Response [U]; IF NextWord (S) = 'Date:' THEN BEGIN // 27 Aug 76 0932 PDT // Tue, 21 Mar 2000 15:51:42 +0100 { from rfc822: dates = orig-date ; Original [ resent-date ] ; Forwarded date-time = [ day "," ] date time ; dd mm yy ; hh:mm:ss zzz day = "Mon" / "Tue" / "Wed" / "Thu" / "Fri" / "Sat" / "Sun"} // needed format: 01-Apr-2001 11:00:55 +0200 I := Pos (',', S); IF I > 0 THEN Delete (S,1,I); // we dont need the day S2 := NextWord (S); // date: dd J := -1; TRY J := StrToInt (S2); EXCEPT END; IF (J < 1) OR (J > 31) THEN EXIT; S2 := IntToStr (J); IF Length (S2) < 2 THEN S2 := '0' + S2; Resu := S2 + '-'; ValidMonth := 'jan,feb,mar,apr,may,jun,jul,aug,sep,oct,nov,dec,'; S2 := AnsiLowerCase (Trim (NextWord (S))); // date: mm IF Pos (S2+',', ValidMonth) = 0 THEN EXIT; Resu := Resu + UpCase (S2[1]) + S2[2] + S2[3] + '-'; S2 := NextWord (S); // date: yy J := -1; TRY J := StrToInt (S2); EXCEPT END; IF J < 0 THEN EXIT; // 2 digit year ? IF J < 100 THEN IF J < 50 THEN INC (J,2000) ELSE INC (J,1900); IF (J < 1970) OR (J > 2200) THEN EXIT; Resu := Resu + IntToStr (J) + ' '; // Time: hh:mm:ss zzz // or hh:mm:ss +xxxx // or hh:mm:ss -xxxx I := Pos (':', S); IF I = 0 THEN EXIT; S2 := Copy (S,1,I-1); Delete (S,1,I); J := -1; TRY J := StrToInt (S2); EXCEPT END; IF (J < 0) OR (J > 23) THEN EXIT; Resu := Resu + S2 + ':'; I := Pos (':', S); IF I = 0 THEN EXIT; S2 := Copy (S,1,I-1); Delete (S,1,I); J := -1; TRY J := StrToInt (S2); EXCEPT END; IF (J < 0) OR (J > 59) THEN EXIT; Resu := Resu + S2 + ':'; I := Pos (' ', S); IF I = 0 THEN EXIT; S2 := Copy (S,1,I-1); Delete (S,1,I); J := -1; TRY J := StrToInt (S2); EXCEPT END; IF (J < 0) OR (J > 59) THEN EXIT; Resu := Resu + S2 + ' '; S := Trim (NextWord (S)); // I do not have a list of valid codes and offsets so i can only // accept the +-xxxx, set +0000 for unknown values IF Length (S) = 5 THEN IF (S[1] = '+') OR (S[1] = '-') AND (S[2] IN ['0'..'9']) AND (S[3] IN ['0'..'9']) AND (S[4] IN ['0'..'9']) AND (S[5] IN ['0'..'9']) THEN BEGIN Result := Resu + S; EXIT; END; Result := Resu + '+0000'; END; END; END; END; END; FUNCTION ImapServer.MessageDate (MessageNumber : INTEGER) : STRING; VAR U : CARDINAL; S : STRING; BEGIN Result := ''; U := MessageNumber; // UID (MessageNumber); IF U > 0 THEN BEGIN IF Command ('FETCH '+IntToStr(U)+' (INTERNALDATE)',TRUE) = 0 THEN BEGIN IF Response.Count > 0 THEN FOR U := 0 TO Response.Count-1 DO BEGIN S := Response [U]; IF NextWord (S) = '*' THEN BEGIN NextWord (S); IF UpperCase (NextWord (S)) = 'FETCH' THEN BEGIN S := NextWord (S); // FLAGS (\bla \bla) IF UpperCase (NextWord(S)) = 'INTERNALDATE' THEN BEGIN Result := NextWord (S); IF NOT MessageDateValid (Result) THEN BEGIN IF DebugCommands THEN log (log_error,' ** INVALID DATE RECEIVED: "'+Result+'"'); Result := ''; // AD 26.01.2002 END; EXIT; END; END; END; END; END; END; END; FUNCTION ImapServer.MessageSave (Mailbox, Msg, Flags, Internaldate : STRING) : INTEGER; VAR S : STRING; OldDbg : BOOLEAN; BEGIN S := ''; OldDbg := DebugCommands; Mailbox := SetQuotationMarksIfNeeded (Mailbox); IF (Flags <> '') THEN Flags := ' ('+Flags+')'; IF Internaldate <> '' THEN Flags := Flags + ' "' + Internaldate+'"'; Result := Command ('APPEND '+Mailbox + Flags + ' {' + IntToStr (Length(Msg)) + '}',TRUE); IF Result = 0 THEN BEGIN IF OldDbg THEN BEGIN WriteLn (#13'S: Message not shown (',Length(Msg),' Bytes)'); DebugCommands := FALSE; END; {IF Length(Msg) = 4095 THEN BEGIN WriteLn; END;} Result := WriteALine (ServSock, Msg + #13#10, DebugCommands); // why the hell do i need 1 additional linefeed ? DebugCommands := OldDbg; IF Result = 0 THEN BEGIN Result := ReadALine (S, StdTimeoutK); IF (Result <> 0) THEN BEGIN {$IFDEF Unix} {$ifdef VER1_0} IF (Result = Sys_ECONNRESET) OR (Result = Sys_ECONNABORTED) THEN {$else} IF (Result = ESysECONNRESET) OR (Result = ESysECONNABORTED) THEN {$endif} {$ELSE} IF (Result = WSAECONNRESET) OR (Result = WSAECONNABORTED) THEN {$ENDIF} LastResult := '[ Server closed connection after message was sent, Err:'+IntToStr(Result)+' ]' ELSE LastResult := '[ Error '+IntToStr(Result)+' receiving data from server ]'; END; WHILE (Result = 0) AND (Copy (S,1,1) = '*') DO // Result := ReadALine (S, -1); Result := ReadALine (S, StdTimeoutK); IF Result = 0 THEN BEGIN NextWord (S); // Skip Axxx or * IF UpperCase (NextWord (S)) <> 'OK' THEN BEGIN Result := IMapErr; LastResult := S; END; END; FlushInBuffer; END; END; END; // ImapServer.MessageSave FUNCTION ImapServer.RemovePersonalNamespace (FolderName : STRING) : STRING; VAR S : STRING; BEGIN IF (NamespaceUser <> '') THEN BEGIN S := NamespaceUser + PathSep; IF (Copy (FolderName,1,Length(S)) = S) THEN Result := Copy (FolderName,Length(S)+1,Length(FolderName)) ELSE Result := FolderName; END ELSE Result := FolderName; END; FUNCTION ImapServer.isOtherUsersFoler (FolderName : STRING) : BOOLEAN; BEGIN Result := FALSE; IF NamespaceOtherUser = '' THEN EXIT; IF FolderName = NamespaceOtherUser THEN Result := TRUE ELSE IF Length (FolderName) >= (Length (NamespaceOtherUser)+Length(PathSep)) THEN IF Copy (FolderName,1,Length(NamespaceOtherUser)+Length(PathSep)) = NamespaceOtherUser+PathSep THEN Result := TRUE; END; FUNCTION ImapServer.isPublicFolder (FolderName : STRING) : BOOLEAN; BEGIN Result := FALSE; IF NamespacePublicFolders = '' THEN EXIT; IF FolderName = NamespacePublicFolders THEN Result := TRUE ELSE IF Length (FolderName) >= (Length (NamespacePublicFolders)+Length(PathSep)) THEN IF Copy (FolderName,1,Length(NamespacePublicFolders)+Length(PathSep)) = NamespacePublicFolders+PathSep THEN Result := TRUE; END; PROCEDURE AddTimeZoneConversionEntry (ZoneAsText,ZoneAsImapOffset : STRING); // e.g. 'UTC','+0000' BEGIN IF TimeZoneTable.IndexOfName(ZoneAsText) > -1 THEN BEGIN log (log_fatal,'Duplicate entry in timezone converion ('+ZoneAsText+'). Check your cfg file.'); halt(1); END; TimeZoneTable.add (ZoneAsText + '=' + ZoneAsImapOffset); END; //----------------------------------------------------------------------------- CONSTRUCTOR TMailbox.Create (Flgs : STRING); BEGIN Flags := Flgs; Flgs := LowerCase (Flags); Noinferiors := FALSE; Noselect := FALSE; Marked := FALSE; Unmarked := FALSE; HasChildren := FALSE; Noinferiors := (Pos ('\noinferiors', Flgs) > 0); Noselect := (Pos ('\noselect', Flgs) > 0); Marked := (Pos ('\marked', Flgs) > 0); Unmarked := (Pos ('\unmarked', Flgs) > 0); HasChildren := (Pos ('\haschildren', Flgs) > 0); END; INITIALIZATION TimeZoneTable := TStringList.Create; TimeZoneTable.Sorted := true; {$IFDEF Win32} // not needed for Unix IF WSAStartup($101, InitData) = 0 THEN Initialized := TRUE ELSE BEGIN WriteLn ('Unable to initialize winsock'); HALT(2); END; {$ENDIF} FINALIZATION {$IFDEF Win32} IF Initialized THEN WSACleanup; {$ENDIF} TimeZoneTable.Free; END.