1 {==============================================================================|
2 | Project : Ararat Synapse | 002.005.004 |
3 |==============================================================================|
4 | Content: IMAP4rev1 client |
5 |==============================================================================|
6 | Copyright (c)1999-2015, Lukas Gebauer |
7 | All rights reserved. |
8 | |
9 | Redistribution and use in source and binary forms, with or without |
10 | modification, are permitted provided that the following conditions are met: |
11 | |
12 | Redistributions of source code must retain the above copyright notice, this |
13 | list of conditions and the following disclaimer. |
14 | |
15 | Redistributions in binary form must reproduce the above copyright notice, |
16 | this list of conditions and the following disclaimer in the documentation |
17 | and/or other materials provided with the distribution. |
18 | |
19 | Neither the name of Lukas Gebauer nor the names of its contributors may |
20 | be used to endorse or promote products derived from this software without |
21 | specific prior written permission. |
22 | |
23 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
24 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
25 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
26 | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
27 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
28 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
29 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
30 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
31 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
32 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
33 | DAMAGE. |
34 |==============================================================================|
35 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
36 | Portions created by Lukas Gebauer are Copyright (c)2001-2015. |
37 | All Rights Reserved. |
38 |==============================================================================|
39 | Contributor(s): |
40 |==============================================================================|
41 | History: see HISTORY.HTM from distribution package |
42 | (Found at URL: http://www.ararat.cz/synapse/) |
43 |==============================================================================}
44
45 {:@abstract(IMAP4 rev1 protocol client)
46
47 Used RFC: RFC-2060, RFC-2595
48 }
49
50 {$IFDEF FPC}
51 {$MODE DELPHI}
52 {$ENDIF}
53 {$H+}
54
55 {$IFDEF UNICODE}
56 {$WARN IMPLICIT_STRING_CAST OFF}
57 {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
58 {$ENDIF}
59
60 unit imapsend;
61
62 interface
63
64 uses
65 SysUtils, Classes,
66 blcksock, synautil;
67
68 const
69 cIMAPProtocol = '143';
70
71 type
72 {:@abstract(Implementation of IMAP4 protocol.)
73 Note: Are you missing properties for setting Username and Password? Look to
74 parent @link(TSynaClient) object!
75
76 Are you missing properties for specify server address and port? Look to
77 parent @link(TSynaClient) too!}
78 TIMAPSend = class(TSynaClient)
79 protected
80 FSock: TTCPBlockSocket;
81 FTagCommand: integer;
82 FResultString: string;
83 FFullResult: TStringList;
84 FIMAPcap: TStringList;
85 FAuthDone: Boolean;
86 FSelectedFolder: string;
87 FSelectedCount: integer;
88 FSelectedRecent: integer;
89 FSelectedUIDvalidity: integer;
90 FUID: Boolean;
91 FAutoTLS: Boolean;
92 FFullSSL: Boolean;
ReadResultnull93 function ReadResult: string;
AuthLoginnull94 function AuthLogin: Boolean;
Connectnull95 function Connect: Boolean;
96 procedure ParseMess(Value:TStrings);
97 procedure ParseFolderList(Value:TStrings);
98 procedure ParseSelect;
99 procedure ParseSearch(Value:TStrings);
100 procedure ProcessLiterals;
101 public
102 constructor Create;
103 destructor Destroy; override;
104
105 {:By this function you can call any IMAP command. Result of this command is
106 in adequate properties.}
IMAPcommandnull107 function IMAPcommand(Value: string): string;
108
109 {:By this function you can call any IMAP command what need upload any data.
110 Result of this command is in adequate properties.}
IMAPuploadCommandnull111 function IMAPuploadCommand(Value: string; const Data:TStrings): string;
112
113 {:Call CAPABILITY command and fill IMAPcap property by new values.}
Capabilitynull114 function Capability: Boolean;
115
116 {:Connect to IMAP server and do login to this server. This command begin
117 session.}
Loginnull118 function Login: Boolean;
119
120 {:Disconnect from IMAP server and terminate session session. If exists some
121 deleted and non-purged messages, these messages are not deleted!}
Logoutnull122 function Logout: Boolean;
123
124 {:Do NOOP. It is for prevent disconnect by timeout.}
NoOpnull125 function NoOp: Boolean;
126
127 {:Lists folder names. You may specify level of listing. If you specify
128 FromFolder as empty string, return is all folders in system.}
Listnull129 function List(FromFolder: string; const FolderList: TStrings): Boolean;
130
131 {:Lists folder names what match search criteria. You may specify level of
132 listing. If you specify FromFolder as empty string, return is all folders
133 in system.}
ListSearchnull134 function ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;
135
136 {:Lists subscribed folder names. You may specify level of listing. If you
137 specify FromFolder as empty string, return is all subscribed folders in
138 system.}
ListSubscribednull139 function ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;
140
141 {:Lists subscribed folder names what matching search criteria. You may
142 specify level of listing. If you specify FromFolder as empty string, return
143 is all subscribed folders in system.}
ListSearchSubscribednull144 function ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
145
146 {:Create a new folder.}
CreateFoldernull147 function CreateFolder(FolderName: string): Boolean;
148
149 {:Delete a folder.}
DeleteFoldernull150 function DeleteFolder(FolderName: string): Boolean;
151
152 {:Rename folder names.}
RenameFoldernull153 function RenameFolder(FolderName, NewFolderName: string): Boolean;
154
155 {:Subscribe folder.}
SubscribeFoldernull156 function SubscribeFolder(FolderName: string): Boolean;
157
158 {:Unsubscribe folder.}
UnsubscribeFoldernull159 function UnsubscribeFolder(FolderName: string): Boolean;
160
161 {:Select folder.}
SelectFoldernull162 function SelectFolder(FolderName: string): Boolean;
163
164 {:Select folder, but only for reading. Any changes are not allowed!}
SelectROFoldernull165 function SelectROFolder(FolderName: string): Boolean;
166
167 {:Close a folder. (end of Selected state)}
CloseFoldernull168 function CloseFolder: Boolean;
169
170 {:Ask for given status of folder. I.e. if you specify as value 'UNSEEN',
171 result is number of unseen messages in folder. For another status
172 indentificator check IMAP documentation and documentation of your IMAP
173 server (each IMAP server can have their own statuses.)}
StatusFoldernull174 function StatusFolder(FolderName, Value: string): integer;
175
176 {:Hardly delete all messages marked as 'deleted' in current selected folder.}
ExpungeFoldernull177 function ExpungeFolder: Boolean;
178
179 {:Touch to folder. (use as update status of folder, etc.)}
CheckFoldernull180 function CheckFolder: Boolean;
181
182 {:Append given message to specified folder.}
AppendMessnull183 function AppendMess(ToFolder: string; const Mess: TStrings): Boolean;
184
185 {:'Delete' message from current selected folder. It mark message as Deleted.
186 Real deleting will be done after sucessfull @link(CloseFolder) or
187 @link(ExpungeFolder)}
DeleteMessnull188 function DeleteMess(MessID: integer): boolean;
189
190 {:Get full message from specified message in selected folder.}
FetchMessnull191 function FetchMess(MessID: integer; const Mess: TStrings): Boolean;
192
193 {:Get message headers only from specified message in selected folder.}
FetchHeadernull194 function FetchHeader(MessID: integer; const Headers: TStrings): Boolean;
195
196 {:Return message size of specified message from current selected folder.}
MessageSizenull197 function MessageSize(MessID: integer): integer;
198
199 {:Copy message from current selected folder to another folder.}
CopyMessnull200 function CopyMess(MessID: integer; ToFolder: string): Boolean;
201
202 {:Return message numbers from currently selected folder as result
203 of searching. Search criteria is very complex language (see to IMAP
204 specification) similar to SQL (but not same syntax!).}
SearchMessnull205 function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
206
207 {:Sets flags of message from current selected folder.}
SetFlagsMessnull208 function SetFlagsMess(MessID: integer; Flags: string): Boolean;
209
210 {:Gets flags of message from current selected folder.}
GetFlagsMessnull211 function GetFlagsMess(MessID: integer; var Flags: string): Boolean;
212
213 {:Add flags to message's flags.}
AddFlagsMessnull214 function AddFlagsMess(MessID: integer; Flags: string): Boolean;
215
216 {:Remove flags from message's flags.}
DelFlagsMessnull217 function DelFlagsMess(MessID: integer; Flags: string): Boolean;
218
219 {:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
StartTLSnull220 function StartTLS: Boolean;
221
222 {:return UID of requested message ID.}
GetUIDnull223 function GetUID(MessID: integer; var UID : Integer): Boolean;
224
225 {:Try to find given capabily in capabilty string returned from IMAP server.}
FindCapnull226 function FindCap(const Value: string): string;
227 published
228 {:Status line with result of last operation.}
229 property ResultString: string read FResultString;
230
231 {:Full result of last IMAP operation.}
232 property FullResult: TStringList read FFullResult;
233
234 {:List of server capabilites.}
235 property IMAPcap: TStringList read FIMAPcap;
236
237 {:Authorization is successful done.}
238 property AuthDone: Boolean read FAuthDone;
239
240 {:Turn on or off usage of UID (unicate identificator) of messages instead
241 only sequence numbers.}
242 property UID: Boolean read FUID Write FUID;
243
244 {:Name of currently selected folder.}
245 property SelectedFolder: string read FSelectedFolder;
246
247 {:Count of messages in currently selected folder.}
248 property SelectedCount: integer read FSelectedCount;
249
250 {:Count of not-visited messages in currently selected folder.}
251 property SelectedRecent: integer read FSelectedRecent;
252
253 {:This number with name of folder is unique indentificator of folder.
254 (If someone delete folder and next create new folder with exactly same name
255 of folder, this number is must be different!)}
256 property SelectedUIDvalidity: integer read FSelectedUIDvalidity;
257
258 {:If is set to true, then upgrade to SSL/TLS mode if remote server support it.}
259 property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
260
261 {:SSL/TLS mode is used from first contact to server. Servers with full
262 SSL/TLS mode usualy using non-standard TCP port!}
263 property FullSSL: Boolean read FFullSSL Write FFullSSL;
264
265 {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
266 property Sock: TTCPBlockSocket read FSock;
267 end;
268
269 implementation
270
271 constructor TIMAPSend.Create;
272 begin
273 inherited Create;
274 FFullResult := TStringList.Create;
275 FIMAPcap := TStringList.Create;
276 FSock := TTCPBlockSocket.Create;
277 FSock.Owner := self;
278 FSock.ConvertLineEnd := True;
279 FSock.SizeRecvBuffer := 32768;
280 FSock.SizeSendBuffer := 32768;
281 FTimeout := 60000;
282 FTargetPort := cIMAPProtocol;
283 FTagCommand := 0;
284 FSelectedFolder := '';
285 FSelectedCount := 0;
286 FSelectedRecent := 0;
287 FSelectedUIDvalidity := 0;
288 FUID := False;
289 FAutoTLS := False;
290 FFullSSL := False;
291 end;
292
293 destructor TIMAPSend.Destroy;
294 begin
295 FSock.Free;
296 FIMAPcap.Free;
297 FFullResult.Free;
298 inherited Destroy;
299 end;
300
301
ReadResultnull302 function TIMAPSend.ReadResult: string;
303 var
304 s: string;
305 x, l: integer;
306 begin
307 Result := '';
308 FFullResult.Clear;
309 FResultString := '';
310 repeat
311 s := FSock.RecvString(FTimeout);
312 if Pos('S' + IntToStr(FTagCommand) + ' ', s) = 1 then
313 begin
314 FResultString := s;
315 break;
316 end
317 else
318 FFullResult.Add(s);
319 if (s <> '') and (s[Length(s)]='}') then
320 begin
321 s := Copy(s, 1, Length(s) - 1);
322 x := RPos('{', s);
323 s := Copy(s, x + 1, Length(s) - x);
324 l := StrToIntDef(s, -1);
325 if l <> -1 then
326 begin
327 s := FSock.RecvBufferStr(l, FTimeout);
328 FFullResult.Add(s);
329 end;
330 end;
331 until FSock.LastError <> 0;
332 s := Trim(separateright(FResultString, ' '));
333 Result:=uppercase(Trim(separateleft(s, ' ')));
334 end;
335
336 procedure TIMAPSend.ProcessLiterals;
337 var
338 l: TStringList;
339 n, x: integer;
340 b: integer;
341 s: string;
342 begin
343 l := TStringList.Create;
344 try
345 l.Assign(FFullResult);
346 FFullResult.Clear;
347 b := 0;
348 for n := 0 to l.Count - 1 do
349 begin
350 s := l[n];
351 if b > 0 then
352 begin
353 FFullResult[FFullresult.Count - 1] :=
354 FFullResult[FFullresult.Count - 1] + s;
355 inc(b);
356 if b > 2 then
357 b := 0;
358 end
359 else
360 begin
361 if (s <> '') and (s[Length(s)]='}') then
362 begin
363 x := RPos('{', s);
364 Delete(s, x, Length(s) - x + 1);
365 b := 1;
366 end
367 else
368 b := 0;
369 FFullResult.Add(s);
370 end;
371 end;
372 finally
373 l.Free;
374 end;
375 end;
376
TIMAPSend.IMAPcommandnull377 function TIMAPSend.IMAPcommand(Value: string): string;
378 begin
379 Inc(FTagCommand);
380 FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + CRLF);
381 Result := ReadResult;
382 end;
383
IMAPuploadCommandnull384 function TIMAPSend.IMAPuploadCommand(Value: string; const Data:TStrings): string;
385 var
386 l: integer;
387 begin
388 Inc(FTagCommand);
389 l := Length(Data.Text);
390 FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF);
391 FSock.RecvString(FTimeout);
392 FSock.SendString(Data.Text + CRLF);
393 Result := ReadResult;
394 end;
395
396 procedure TIMAPSend.ParseMess(Value:TStrings);
397 var
398 n: integer;
399 begin
400 Value.Clear;
401 for n := 0 to FFullResult.Count - 2 do
402 if (length(FFullResult[n]) > 0) and (FFullResult[n][Length(FFullResult[n])] = '}') then
403 begin
404 Value.Text := FFullResult[n + 1];
405 Break;
406 end;
407 end;
408
409 procedure TIMAPSend.ParseFolderList(Value:TStrings);
410 var
411 n, x: integer;
412 s: string;
413 begin
414 ProcessLiterals;
415 Value.Clear;
416 for n := 0 to FFullResult.Count - 1 do
417 begin
418 s := FFullResult[n];
419 if (s <> '') and (Pos('\NOSELECT', UpperCase(s)) = 0) then
420 begin
421 if s[Length(s)] = '"' then
422 begin
423 Delete(s, Length(s), 1);
424 x := RPos('"', s);
425 end
426 else
427 x := RPos(' ', s);
428 if (x > 0) then
429 Value.Add(Copy(s, x + 1, Length(s) - x));
430 end;
431 end;
432 end;
433
434 procedure TIMAPSend.ParseSelect;
435 var
436 n: integer;
437 s, t: string;
438 begin
439 ProcessLiterals;
440 FSelectedCount := 0;
441 FSelectedRecent := 0;
442 FSelectedUIDvalidity := 0;
443 for n := 0 to FFullResult.Count - 1 do
444 begin
445 s := uppercase(FFullResult[n]);
446 if Pos(' EXISTS', s) > 0 then
447 begin
448 t := Trim(separateleft(s, ' EXISTS'));
449 t := Trim(separateright(t, '* '));
450 FSelectedCount := StrToIntDef(t, 0);
451 end;
452 if Pos(' RECENT', s) > 0 then
453 begin
454 t := Trim(separateleft(s, ' RECENT'));
455 t := Trim(separateright(t, '* '));
456 FSelectedRecent := StrToIntDef(t, 0);
457 end;
458 if Pos('UIDVALIDITY', s) > 0 then
459 begin
460 t := Trim(separateright(s, 'UIDVALIDITY '));
461 t := Trim(separateleft(t, ']'));
462 FSelectedUIDvalidity := StrToIntDef(t, 0);
463 end;
464 end;
465 end;
466
467 procedure TIMAPSend.ParseSearch(Value:TStrings);
468 var
469 n: integer;
470 s: string;
471 begin
472 ProcessLiterals;
473 Value.Clear;
474 for n := 0 to FFullResult.Count - 1 do
475 begin
476 s := uppercase(FFullResult[n]);
477 if Pos('* SEARCH', s) = 1 then
478 begin
479 s := Trim(SeparateRight(s, '* SEARCH'));
480 while s <> '' do
481 Value.Add(Fetch(s, ' '));
482 end;
483 end;
484 end;
485
FindCapnull486 function TIMAPSend.FindCap(const Value: string): string;
487 var
488 n: Integer;
489 s: string;
490 begin
491 s := UpperCase(Value);
492 Result := '';
493 for n := 0 to FIMAPcap.Count - 1 do
494 if Pos(s, UpperCase(FIMAPcap[n])) = 1 then
495 begin
496 Result := FIMAPcap[n];
497 Break;
498 end;
499 end;
500
TIMAPSend.AuthLoginnull501 function TIMAPSend.AuthLogin: Boolean;
502 begin
503 Result := IMAPcommand('LOGIN "' + FUsername + '" "' + FPassword + '"') = 'OK';
504 if Result then
505 FAuthDone := True;
506 end;
507
Connectnull508 function TIMAPSend.Connect: Boolean;
509 begin
510 FSock.CloseSocket;
511 FSock.Bind(FIPInterface, cAnyPort);
512 if FSock.LastError = 0 then
513 FSock.Connect(FTargetHost, FTargetPort);
514 if FSock.LastError = 0 then
515 if FFullSSL then
516 FSock.SSLDoConnect;
517 Result := FSock.LastError = 0;
518 end;
519
Capabilitynull520 function TIMAPSend.Capability: Boolean;
521 var
522 n: Integer;
523 s, t: string;
524 begin
525 Result := False;
526 FIMAPcap.Clear;
527 s := IMAPcommand('CAPABILITY');
528 if s = 'OK' then
529 begin
530 ProcessLiterals;
531 for n := 0 to FFullResult.Count - 1 do
532 if Pos('* CAPABILITY ', FFullResult[n]) = 1 then
533 begin
534 s := Trim(SeparateRight(FFullResult[n], '* CAPABILITY '));
535 while not (s = '') do
536 begin
537 t := Trim(separateleft(s, ' '));
538 s := Trim(separateright(s, ' '));
539 if s = t then
540 s := '';
541 FIMAPcap.Add(t);
542 end;
543 end;
544 Result := True;
545 end;
546 end;
547
TIMAPSend.Loginnull548 function TIMAPSend.Login: Boolean;
549 var
550 s: string;
551 begin
552 FSelectedFolder := '';
553 FSelectedCount := 0;
554 FSelectedRecent := 0;
555 FSelectedUIDvalidity := 0;
556 Result := False;
557 FAuthDone := False;
558 if not Connect then
559 Exit;
560 s := FSock.RecvString(FTimeout);
561 if Pos('* PREAUTH', s) = 1 then
562 FAuthDone := True
563 else
564 if Pos('* OK', s) = 1 then
565 FAuthDone := False
566 else
567 Exit;
568 if Capability then
569 begin
570 if Findcap('IMAP4rev1') = '' then
571 Exit;
572 if FAutoTLS and (Findcap('STARTTLS') <> '') then
573 if StartTLS then
574 Capability;
575 end;
576 Result := AuthLogin;
577 end;
578
Logoutnull579 function TIMAPSend.Logout: Boolean;
580 begin
581 Result := IMAPcommand('LOGOUT') = 'OK';
582 FSelectedFolder := '';
583 FSock.CloseSocket;
584 end;
585
NoOpnull586 function TIMAPSend.NoOp: Boolean;
587 begin
588 Result := IMAPcommand('NOOP') = 'OK';
589 end;
590
TIMAPSend.Listnull591 function TIMAPSend.List(FromFolder: string; const FolderList: TStrings): Boolean;
592 begin
593 Result := IMAPcommand('LIST "' + FromFolder + '" *') = 'OK';
594 ParseFolderList(FolderList);
595 end;
596
TIMAPSend.ListSearchnull597 function TIMAPSend.ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;
598 begin
599 Result := IMAPcommand('LIST "' + FromFolder + '" "' + Search +'"') = 'OK';
600 ParseFolderList(FolderList);
601 end;
602
ListSubscribednull603 function TIMAPSend.ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;
604 begin
605 Result := IMAPcommand('LSUB "' + FromFolder + '" *') = 'OK';
606 ParseFolderList(FolderList);
607 end;
608
ListSearchSubscribednull609 function TIMAPSend.ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
610 begin
611 Result := IMAPcommand('LSUB "' + FromFolder + '" "' + Search +'"') = 'OK';
612 ParseFolderList(FolderList);
613 end;
614
TIMAPSend.CreateFoldernull615 function TIMAPSend.CreateFolder(FolderName: string): Boolean;
616 begin
617 Result := IMAPcommand('CREATE "' + FolderName + '"') = 'OK';
618 end;
619
TIMAPSend.DeleteFoldernull620 function TIMAPSend.DeleteFolder(FolderName: string): Boolean;
621 begin
622 Result := IMAPcommand('DELETE "' + FolderName + '"') = 'OK';
623 end;
624
RenameFoldernull625 function TIMAPSend.RenameFolder(FolderName, NewFolderName: string): Boolean;
626 begin
627 Result := IMAPcommand('RENAME "' + FolderName + '" "' + NewFolderName + '"') = 'OK';
628 end;
629
TIMAPSend.SubscribeFoldernull630 function TIMAPSend.SubscribeFolder(FolderName: string): Boolean;
631 begin
632 Result := IMAPcommand('SUBSCRIBE "' + FolderName + '"') = 'OK';
633 end;
634
UnsubscribeFoldernull635 function TIMAPSend.UnsubscribeFolder(FolderName: string): Boolean;
636 begin
637 Result := IMAPcommand('UNSUBSCRIBE "' + FolderName + '"') = 'OK';
638 end;
639
TIMAPSend.SelectFoldernull640 function TIMAPSend.SelectFolder(FolderName: string): Boolean;
641 begin
642 Result := IMAPcommand('SELECT "' + FolderName + '"') = 'OK';
643 FSelectedFolder := FolderName;
644 ParseSelect;
645 end;
646
SelectROFoldernull647 function TIMAPSend.SelectROFolder(FolderName: string): Boolean;
648 begin
649 Result := IMAPcommand('EXAMINE "' + FolderName + '"') = 'OK';
650 FSelectedFolder := FolderName;
651 ParseSelect;
652 end;
653
CloseFoldernull654 function TIMAPSend.CloseFolder: Boolean;
655 begin
656 Result := IMAPcommand('CLOSE') = 'OK';
657 FSelectedFolder := '';
658 end;
659
StatusFoldernull660 function TIMAPSend.StatusFolder(FolderName, Value: string): integer;
661 var
662 n: integer;
663 s, t: string;
664 begin
665 Result := -1;
666 Value := Uppercase(Value);
667 if IMAPcommand('STATUS "' + FolderName + '" (' + Value + ')' ) = 'OK' then
668 begin
669 ProcessLiterals;
670 for n := 0 to FFullResult.Count - 1 do
671 begin
672 s := FFullResult[n];
673 // s := UpperCase(FFullResult[n]);
674 if (Pos('* ', s) = 1) and (Pos(FolderName, s) >= 1) and (Pos(Value, s) > 0 ) then
675 begin
676 t := SeparateRight(s, Value);
677 t := SeparateLeft(t, ')');
678 t := trim(t);
679 Result := StrToIntDef(t, -1);
680 Break;
681 end;
682 end;
683 end;
684 end;
685
TIMAPSend.ExpungeFoldernull686 function TIMAPSend.ExpungeFolder: Boolean;
687 begin
688 Result := IMAPcommand('EXPUNGE') = 'OK';
689 end;
690
CheckFoldernull691 function TIMAPSend.CheckFolder: Boolean;
692 begin
693 Result := IMAPcommand('CHECK') = 'OK';
694 end;
695
AppendMessnull696 function TIMAPSend.AppendMess(ToFolder: string; const Mess: TStrings): Boolean;
697 begin
698 Result := IMAPuploadCommand('APPEND "' + ToFolder + '"', Mess) = 'OK';
699 end;
700
TIMAPSend.DeleteMessnull701 function TIMAPSend.DeleteMess(MessID: integer): boolean;
702 var
703 s: string;
704 begin
705 s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (\Deleted)';
706 if FUID then
707 s := 'UID ' + s;
708 Result := IMAPcommand(s) = 'OK';
709 end;
710
TIMAPSend.FetchMessnull711 function TIMAPSend.FetchMess(MessID: integer; const Mess: TStrings): Boolean;
712 var
713 s: string;
714 begin
715 s := 'FETCH ' + IntToStr(MessID) + ' (RFC822)';
716 if FUID then
717 s := 'UID ' + s;
718 Result := IMAPcommand(s) = 'OK';
719 ParseMess(Mess);
720 end;
721
TIMAPSend.FetchHeadernull722 function TIMAPSend.FetchHeader(MessID: integer; const Headers: TStrings): Boolean;
723 var
724 s: string;
725 begin
726 s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.HEADER)';
727 if FUID then
728 s := 'UID ' + s;
729 Result := IMAPcommand(s) = 'OK';
730 ParseMess(Headers);
731 end;
732
MessageSizenull733 function TIMAPSend.MessageSize(MessID: integer): integer;
734 var
735 n: integer;
736 s, t: string;
737 begin
738 Result := -1;
739 s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.SIZE)';
740 if FUID then
741 s := 'UID ' + s;
742 if IMAPcommand(s) = 'OK' then
743 begin
744 ProcessLiterals;
745 for n := 0 to FFullResult.Count - 1 do
746 begin
747 s := UpperCase(FFullResult[n]);
748 if (Pos('* ', s) = 1) and (Pos('RFC822.SIZE', s) > 0 ) then
749 begin
750 t := SeparateRight(s, 'RFC822.SIZE ');
751 t := Trim(SeparateLeft(t, ')'));
752 t := Trim(SeparateLeft(t, ' '));
753 Result := StrToIntDef(t, -1);
754 Break;
755 end;
756 end;
757 end;
758 end;
759
CopyMessnull760 function TIMAPSend.CopyMess(MessID: integer; ToFolder: string): Boolean;
761 var
762 s: string;
763 begin
764 s := 'COPY ' + IntToStr(MessID) + ' "' + ToFolder + '"';
765 if FUID then
766 s := 'UID ' + s;
767 Result := IMAPcommand(s) = 'OK';
768 end;
769
TIMAPSend.SearchMessnull770 function TIMAPSend.SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
771 var
772 s: string;
773 begin
774 s := 'SEARCH ' + Criteria;
775 if FUID then
776 s := 'UID ' + s;
777 Result := IMAPcommand(s) = 'OK';
778 ParseSearch(FoundMess);
779 end;
780
SetFlagsMessnull781 function TIMAPSend.SetFlagsMess(MessID: integer; Flags: string): Boolean;
782 var
783 s: string;
784 begin
785 s := 'STORE ' + IntToStr(MessID) + ' FLAGS.SILENT (' + Flags + ')';
786 if FUID then
787 s := 'UID ' + s;
788 Result := IMAPcommand(s) = 'OK';
789 end;
790
AddFlagsMessnull791 function TIMAPSend.AddFlagsMess(MessID: integer; Flags: string): Boolean;
792 var
793 s: string;
794 begin
795 s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (' + Flags + ')';
796 if FUID then
797 s := 'UID ' + s;
798 Result := IMAPcommand(s) = 'OK';
799 end;
800
DelFlagsMessnull801 function TIMAPSend.DelFlagsMess(MessID: integer; Flags: string): Boolean;
802 var
803 s: string;
804 begin
805 s := 'STORE ' + IntToStr(MessID) + ' -FLAGS.SILENT (' + Flags + ')';
806 if FUID then
807 s := 'UID ' + s;
808 Result := IMAPcommand(s) = 'OK';
809 end;
810
TIMAPSend.GetFlagsMessnull811 function TIMAPSend.GetFlagsMess(MessID: integer; var Flags: string): Boolean;
812 var
813 s: string;
814 n: integer;
815 begin
816 Flags := '';
817 s := 'FETCH ' + IntToStr(MessID) + ' (FLAGS)';
818 if FUID then
819 s := 'UID ' + s;
820 Result := IMAPcommand(s) = 'OK';
821 ProcessLiterals;
822 for n := 0 to FFullResult.Count - 1 do
823 begin
824 s := uppercase(FFullResult[n]);
825 if (Pos('* ', s) = 1) and (Pos('FLAGS', s) > 0 ) then
826 begin
827 s := SeparateRight(s, 'FLAGS');
828 s := Separateright(s, '(');
829 Flags := Trim(SeparateLeft(s, ')'));
830 end;
831 end;
832 end;
833
TIMAPSend.StartTLSnull834 function TIMAPSend.StartTLS: Boolean;
835 begin
836 Result := False;
837 if FindCap('STARTTLS') <> '' then
838 begin
839 if IMAPcommand('STARTTLS') = 'OK' then
840 begin
841 Fsock.SSLDoConnect;
842 Result := FSock.LastError = 0;
843 end;
844 end;
845 end;
846
847 //Paul Buskermolen <p.buskermolen@pinkroccade.com>
GetUIDnull848 function TIMAPSend.GetUID(MessID: integer; var UID : Integer): boolean;
849 var
850 s, sUid: string;
851 n: integer;
852 begin
853 sUID := '';
854 s := 'FETCH ' + IntToStr(MessID) + ' UID';
855 Result := IMAPcommand(s) = 'OK';
856 ProcessLiterals;
857 for n := 0 to FFullResult.Count - 1 do
858 begin
859 s := uppercase(FFullResult[n]);
860 if Pos('FETCH (UID', s) >= 1 then
861 begin
862 s := Separateright(s, '(UID ');
863 sUID := Trim(SeparateLeft(s, ')'));
864 end;
865 end;
866 UID := StrToIntDef(sUID, 0);
867 end;
868
869 {==============================================================================}
870
871 end.
872