source: trunk/Demo/Packages/synapse/imapsend.pas

Last change on this file was 60, checked in by chronos, 13 years ago
File size: 25.8 KB
Line 
1{==============================================================================|
2| Project : Ararat Synapse | 002.005.001 |
3|==============================================================================|
4| Content: IMAP4rev1 client |
5|==============================================================================|
6| Copyright (c)1999-2004, 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-2004. |
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
47Used RFC: RFC-2060, RFC-2595
48}
49
50{$IFDEF FPC}
51 {$MODE DELPHI}
52{$ENDIF}
53{$H+}
54
55unit imapsend;
56
57interface
58
59uses
60 SysUtils, Classes,
61 blcksock, synautil;
62
63const
64 cIMAPProtocol = '143';
65
66type
67 {:@abstract(Implementation of IMAP4 protocol.)
68 Note: Are you missing properties for setting Username and Password? Look to
69 parent @link(TSynaClient) object!
70
71 Are you missing properties for specify server address and port? Look to
72 parent @link(TSynaClient) too!}
73 TIMAPSend = class(TSynaClient)
74 protected
75 FSock: TTCPBlockSocket;
76 FTagCommand: integer;
77 FResultString: string;
78 FFullResult: TStringList;
79 FIMAPcap: TStringList;
80 FAuthDone: Boolean;
81 FSelectedFolder: string;
82 FSelectedCount: integer;
83 FSelectedRecent: integer;
84 FSelectedUIDvalidity: integer;
85 FUID: Boolean;
86 FAutoTLS: Boolean;
87 FFullSSL: Boolean;
88 function ReadResult: string;
89 function AuthLogin: Boolean;
90 function Connect: Boolean;
91 procedure ParseMess(Value:TStrings);
92 procedure ParseFolderList(Value:TStrings);
93 procedure ParseSelect;
94 procedure ParseSearch(Value:TStrings);
95 procedure ProcessLiterals;
96 public
97 constructor Create;
98 destructor Destroy; override;
99
100 {:By this function you can call any IMAP command. Result of this command is
101 in adequate properties.}
102 function IMAPcommand(Value: string): string;
103
104 {:By this function you can call any IMAP command what need upload any data.
105 Result of this command is in adequate properties.}
106 function IMAPuploadCommand(Value: string; const Data:TStrings): string;
107
108 {:Call CAPABILITY command and fill IMAPcap property by new values.}
109 function Capability: Boolean;
110
111 {:Connect to IMAP server and do login to this server. This command begin
112 session.}
113 function Login: Boolean;
114
115 {:Disconnect from IMAP server and terminate session session. If exists some
116 deleted and non-purged messages, these messages are not deleted!}
117 function Logout: Boolean;
118
119 {:Do NOOP. It is for prevent disconnect by timeout.}
120 function NoOp: Boolean;
121
122 {:Lists folder names. You may specify level of listing. If you specify
123 FromFolder as empty string, return is all folders in system.}
124 function List(FromFolder: string; const FolderList: TStrings): Boolean;
125
126 {:Lists folder names what match search criteria. You may specify level of
127 listing. If you specify FromFolder as empty string, return is all folders
128 in system.}
129 function ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;
130
131 {:Lists subscribed folder names. You may specify level of listing. If you
132 specify FromFolder as empty string, return is all subscribed folders in
133 system.}
134 function ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;
135
136 {:Lists subscribed folder names what matching search criteria. You may
137 specify level of listing. If you specify FromFolder as empty string, return
138 is all subscribed folders in system.}
139 function ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
140
141 {:Create a new folder.}
142 function CreateFolder(FolderName: string): Boolean;
143
144 {:Delete a folder.}
145 function DeleteFolder(FolderName: string): Boolean;
146
147 {:Rename folder names.}
148 function RenameFolder(FolderName, NewFolderName: string): Boolean;
149
150 {:Subscribe folder.}
151 function SubscribeFolder(FolderName: string): Boolean;
152
153 {:Unsubscribe folder.}
154 function UnsubscribeFolder(FolderName: string): Boolean;
155
156 {:Select folder.}
157 function SelectFolder(FolderName: string): Boolean;
158
159 {:Select folder, but only for reading. Any changes are not allowed!}
160 function SelectROFolder(FolderName: string): Boolean;
161
162 {:Close a folder. (end of Selected state)}
163 function CloseFolder: Boolean;
164
165 {:Ask for given status of folder. I.e. if you specify as value 'UNSEEN',
166 result is number of unseen messages in folder. For another status
167 indentificator check IMAP documentation and documentation of your IMAP
168 server (each IMAP server can have their own statuses.)}
169 function StatusFolder(FolderName, Value: string): integer;
170
171 {:Hardly delete all messages marked as 'deleted' in current selected folder.}
172 function ExpungeFolder: Boolean;
173
174 {:Touch to folder. (use as update status of folder, etc.)}
175 function CheckFolder: Boolean;
176
177 {:Append given message to specified folder.}
178 function AppendMess(ToFolder: string; const Mess: TStrings): Boolean;
179
180 {:'Delete' message from current selected folder. It mark message as Deleted.
181 Real deleting will be done after sucessfull @link(CloseFolder) or
182 @link(ExpungeFolder)}
183 function DeleteMess(MessID: integer): boolean;
184
185 {:Get full message from specified message in selected folder.}
186 function FetchMess(MessID: integer; const Mess: TStrings): Boolean;
187
188 {:Get message headers only from specified message in selected folder.}
189 function FetchHeader(MessID: integer; const Headers: TStrings): Boolean;
190
191 {:Return message size of specified message from current selected folder.}
192 function MessageSize(MessID: integer): integer;
193
194 {:Copy message from current selected folder to another folder.}
195 function CopyMess(MessID: integer; ToFolder: string): Boolean;
196
197 {:Return message numbers from currently selected folder as result
198 of searching. Search criteria is very complex language (see to IMAP
199 specification) similar to SQL (but not same syntax!).}
200 function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
201
202 {:Sets flags of message from current selected folder.}
203 function SetFlagsMess(MessID: integer; Flags: string): Boolean;
204
205 {:Gets flags of message from current selected folder.}
206 function GetFlagsMess(MessID: integer; var Flags: string): Boolean;
207
208 {:Add flags to message's flags.}
209 function AddFlagsMess(MessID: integer; Flags: string): Boolean;
210
211 {:Remove flags from message's flags.}
212 function DelFlagsMess(MessID: integer; Flags: string): Boolean;
213
214 {:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
215 function StartTLS: Boolean;
216
217 {:return UID of requested message ID.}
218 function GetUID(MessID: integer; var UID : Integer): Boolean;
219
220 {:Try to find given capabily in capabilty string returned from IMAP server.}
221 function FindCap(const Value: string): string;
222 published
223 {:Status line with result of last operation.}
224 property ResultString: string read FResultString;
225
226 {:Full result of last IMAP operation.}
227 property FullResult: TStringList read FFullResult;
228
229 {:List of server capabilites.}
230 property IMAPcap: TStringList read FIMAPcap;
231
232 {:Authorization is successful done.}
233 property AuthDone: Boolean read FAuthDone;
234
235 {:Turn on or off usage of UID (unicate identificator) of messages instead
236 only sequence numbers.}
237 property UID: Boolean read FUID Write FUID;
238
239 {:Name of currently selected folder.}
240 property SelectedFolder: string read FSelectedFolder;
241
242 {:Count of messages in currently selected folder.}
243 property SelectedCount: integer read FSelectedCount;
244
245 {:Count of not-visited messages in currently selected folder.}
246 property SelectedRecent: integer read FSelectedRecent;
247
248 {:This number with name of folder is unique indentificator of folder.
249 (If someone delete folder and next create new folder with exactly same name
250 of folder, this number is must be different!)}
251 property SelectedUIDvalidity: integer read FSelectedUIDvalidity;
252
253 {:If is set to true, then upgrade to SSL/TLS mode if remote server support it.}
254 property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
255
256 {:SSL/TLS mode is used from first contact to server. Servers with full
257 SSL/TLS mode usualy using non-standard TCP port!}
258 property FullSSL: Boolean read FFullSSL Write FFullSSL;
259
260 {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
261 property Sock: TTCPBlockSocket read FSock;
262 end;
263
264implementation
265
266constructor TIMAPSend.Create;
267begin
268 inherited Create;
269 FFullResult := TStringList.Create;
270 FIMAPcap := TStringList.Create;
271 FSock := TTCPBlockSocket.Create;
272 FSock.ConvertLineEnd := True;
273 FSock.SizeRecvBuffer := 32768;
274 FSock.SizeSendBuffer := 32768;
275 FTimeout := 60000;
276 FTargetPort := cIMAPProtocol;
277 FTagCommand := 0;
278 FSelectedFolder := '';
279 FSelectedCount := 0;
280 FSelectedRecent := 0;
281 FSelectedUIDvalidity := 0;
282 FUID := False;
283 FAutoTLS := False;
284 FFullSSL := False;
285end;
286
287destructor TIMAPSend.Destroy;
288begin
289 FSock.Free;
290 FIMAPcap.Free;
291 FFullResult.Free;
292 inherited Destroy;
293end;
294
295
296function TIMAPSend.ReadResult: string;
297var
298 s: string;
299 x, l: integer;
300begin
301 Result := '';
302 FFullResult.Clear;
303 FResultString := '';
304 repeat
305 s := FSock.RecvString(FTimeout);
306 if Pos('S' + IntToStr(FTagCommand) + ' ', s) = 1 then
307 begin
308 FResultString := s;
309 break;
310 end
311 else
312 FFullResult.Add(s);
313 if (s <> '') and (s[Length(s)]='}') then
314 begin
315 s := Copy(s, 1, Length(s) - 1);
316 x := RPos('{', s);
317 s := Copy(s, x + 1, Length(s) - x);
318 l := StrToIntDef(s, -1);
319 if l <> -1 then
320 begin
321 s := FSock.RecvBufferStr(l, FTimeout);
322 FFullResult.Add(s);
323 end;
324 end;
325 until FSock.LastError <> 0;
326 s := Trim(separateright(FResultString, ' '));
327 Result:=uppercase(Trim(separateleft(s, ' ')));
328end;
329
330procedure TIMAPSend.ProcessLiterals;
331var
332 l: TStringList;
333 n, x: integer;
334 b: integer;
335 s: string;
336begin
337 l := TStringList.Create;
338 try
339 l.Assign(FFullResult);
340 FFullResult.Clear;
341 b := 0;
342 for n := 0 to l.Count - 1 do
343 begin
344 s := l[n];
345 if b > 0 then
346 begin
347 FFullResult[FFullresult.Count - 1] :=
348 FFullResult[FFullresult.Count - 1] + s;
349 inc(b);
350 if b > 2 then
351 b := 0;
352 end
353 else
354 begin
355 if (s <> '') and (s[Length(s)]='}') then
356 begin
357 x := RPos('{', s);
358 Delete(s, x, Length(s) - x + 1);
359 b := 1;
360 end
361 else
362 b := 0;
363 FFullResult.Add(s);
364 end;
365 end;
366 finally
367 l.Free;
368 end;
369end;
370
371function TIMAPSend.IMAPcommand(Value: string): string;
372begin
373 Inc(FTagCommand);
374 FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + CRLF);
375 Result := ReadResult;
376end;
377
378function TIMAPSend.IMAPuploadCommand(Value: string; const Data:TStrings): string;
379var
380 l: integer;
381begin
382 Inc(FTagCommand);
383 l := Length(Data.Text);
384 FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF);
385 FSock.RecvString(FTimeout);
386 FSock.SendString(Data.Text + CRLF);
387 Result := ReadResult;
388end;
389
390procedure TIMAPSend.ParseMess(Value:TStrings);
391var
392 n: integer;
393begin
394 Value.Clear;
395 for n := 0 to FFullResult.Count - 2 do
396 if FFullResult[n][Length(FFullResult[n])] = '}' then
397 begin
398 Value.Text := FFullResult[n + 1];
399 Break;
400 end;
401end;
402
403procedure TIMAPSend.ParseFolderList(Value:TStrings);
404var
405 n, x: integer;
406 s: string;
407begin
408 ProcessLiterals;
409 Value.Clear;
410 for n := 0 to FFullResult.Count - 1 do
411 begin
412 s := FFullResult[n];
413 if (s <> '') and (Pos('\NOSELECT', UpperCase(s)) = 0) then
414 begin
415 if s[Length(s)] = '"' then
416 begin
417 Delete(s, Length(s), 1);
418 x := RPos('"', s);
419 end
420 else
421 x := RPos(' ', s);
422 if (x > 0) then
423 Value.Add(Copy(s, x + 1, Length(s) - x));
424 end;
425 end;
426end;
427
428procedure TIMAPSend.ParseSelect;
429var
430 n: integer;
431 s, t: string;
432begin
433 ProcessLiterals;
434 FSelectedCount := 0;
435 FSelectedRecent := 0;
436 FSelectedUIDvalidity := 0;
437 for n := 0 to FFullResult.Count - 1 do
438 begin
439 s := uppercase(FFullResult[n]);
440 if Pos(' EXISTS', s) > 0 then
441 begin
442 t := Trim(separateleft(s, ' EXISTS'));
443 t := Trim(separateright(t, '* '));
444 FSelectedCount := StrToIntDef(t, 0);
445 end;
446 if Pos(' RECENT', s) > 0 then
447 begin
448 t := Trim(separateleft(s, ' RECENT'));
449 t := Trim(separateright(t, '* '));
450 FSelectedRecent := StrToIntDef(t, 0);
451 end;
452 if Pos('UIDVALIDITY', s) > 0 then
453 begin
454 t := Trim(separateright(s, 'UIDVALIDITY '));
455 t := Trim(separateleft(t, ']'));
456 FSelectedUIDvalidity := StrToIntDef(t, 0);
457 end;
458 end;
459end;
460
461procedure TIMAPSend.ParseSearch(Value:TStrings);
462var
463 n: integer;
464 s: string;
465begin
466 ProcessLiterals;
467 Value.Clear;
468 for n := 0 to FFullResult.Count - 1 do
469 begin
470 s := uppercase(FFullResult[n]);
471 if Pos('* SEARCH', s) = 1 then
472 begin
473 s := Trim(SeparateRight(s, '* SEARCH'));
474 while s <> '' do
475 Value.Add(Fetch(s, ' '));
476 end;
477 end;
478end;
479
480function TIMAPSend.FindCap(const Value: string): string;
481var
482 n: Integer;
483 s: string;
484begin
485 s := UpperCase(Value);
486 Result := '';
487 for n := 0 to FIMAPcap.Count - 1 do
488 if Pos(s, UpperCase(FIMAPcap[n])) = 1 then
489 begin
490 Result := FIMAPcap[n];
491 Break;
492 end;
493end;
494
495function TIMAPSend.AuthLogin: Boolean;
496begin
497 Result := IMAPcommand('LOGIN "' + FUsername + '" "' + FPassword + '"') = 'OK';
498end;
499
500function TIMAPSend.Connect: Boolean;
501begin
502 FSock.CloseSocket;
503 FSock.Bind(FIPInterface, cAnyPort);
504 if FSock.LastError = 0 then
505 FSock.Connect(FTargetHost, FTargetPort);
506 if FSock.LastError = 0 then
507 if FFullSSL then
508 FSock.SSLDoConnect;
509 Result := FSock.LastError = 0;
510end;
511
512function TIMAPSend.Capability: Boolean;
513var
514 n: Integer;
515 s, t: string;
516begin
517 Result := False;
518 FIMAPcap.Clear;
519 s := IMAPcommand('CAPABILITY');
520 if s = 'OK' then
521 begin
522 ProcessLiterals;
523 for n := 0 to FFullResult.Count - 1 do
524 if Pos('* CAPABILITY ', FFullResult[n]) = 1 then
525 begin
526 s := Trim(SeparateRight(FFullResult[n], '* CAPABILITY '));
527 while not (s = '') do
528 begin
529 t := Trim(separateleft(s, ' '));
530 s := Trim(separateright(s, ' '));
531 if s = t then
532 s := '';
533 FIMAPcap.Add(t);
534 end;
535 end;
536 Result := True;
537 end;
538end;
539
540function TIMAPSend.Login: Boolean;
541var
542 s: string;
543begin
544 FSelectedFolder := '';
545 FSelectedCount := 0;
546 FSelectedRecent := 0;
547 FSelectedUIDvalidity := 0;
548 Result := False;
549 FAuthDone := False;
550 if not Connect then
551 Exit;
552 s := FSock.RecvString(FTimeout);
553 if Pos('* PREAUTH', s) = 1 then
554 FAuthDone := True
555 else
556 if Pos('* OK', s) = 1 then
557 FAuthDone := False
558 else
559 Exit;
560 if Capability then
561 begin
562 if Findcap('IMAP4rev1') = '' then
563 Exit;
564 if FAutoTLS and (Findcap('STARTTLS') <> '') then
565 if StartTLS then
566 Capability;
567 end;
568 Result := AuthLogin;
569end;
570
571function TIMAPSend.Logout: Boolean;
572begin
573 Result := IMAPcommand('LOGOUT') = 'OK';
574 FSelectedFolder := '';
575 FSock.CloseSocket;
576end;
577
578function TIMAPSend.NoOp: Boolean;
579begin
580 Result := IMAPcommand('NOOP') = 'OK';
581end;
582
583function TIMAPSend.List(FromFolder: string; const FolderList: TStrings): Boolean;
584begin
585 Result := IMAPcommand('LIST "' + FromFolder + '" *') = 'OK';
586 ParseFolderList(FolderList);
587end;
588
589function TIMAPSend.ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;
590begin
591 Result := IMAPcommand('LIST "' + FromFolder + '" "' + Search +'"') = 'OK';
592 ParseFolderList(FolderList);
593end;
594
595function TIMAPSend.ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;
596begin
597 Result := IMAPcommand('LSUB "' + FromFolder + '" *') = 'OK';
598 ParseFolderList(FolderList);
599end;
600
601function TIMAPSend.ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
602begin
603 Result := IMAPcommand('LSUB "' + FromFolder + '" "' + Search +'"') = 'OK';
604 ParseFolderList(FolderList);
605end;
606
607function TIMAPSend.CreateFolder(FolderName: string): Boolean;
608begin
609 Result := IMAPcommand('CREATE "' + FolderName + '"') = 'OK';
610end;
611
612function TIMAPSend.DeleteFolder(FolderName: string): Boolean;
613begin
614 Result := IMAPcommand('DELETE "' + FolderName + '"') = 'OK';
615end;
616
617function TIMAPSend.RenameFolder(FolderName, NewFolderName: string): Boolean;
618begin
619 Result := IMAPcommand('RENAME "' + FolderName + '" "' + NewFolderName + '"') = 'OK';
620end;
621
622function TIMAPSend.SubscribeFolder(FolderName: string): Boolean;
623begin
624 Result := IMAPcommand('SUBSCRIBE "' + FolderName + '"') = 'OK';
625end;
626
627function TIMAPSend.UnsubscribeFolder(FolderName: string): Boolean;
628begin
629 Result := IMAPcommand('UNSUBSCRIBE "' + FolderName + '"') = 'OK';
630end;
631
632function TIMAPSend.SelectFolder(FolderName: string): Boolean;
633begin
634 Result := IMAPcommand('SELECT "' + FolderName + '"') = 'OK';
635 FSelectedFolder := FolderName;
636 ParseSelect;
637end;
638
639function TIMAPSend.SelectROFolder(FolderName: string): Boolean;
640begin
641 Result := IMAPcommand('EXAMINE "' + FolderName + '"') = 'OK';
642 FSelectedFolder := FolderName;
643 ParseSelect;
644end;
645
646function TIMAPSend.CloseFolder: Boolean;
647begin
648 Result := IMAPcommand('CLOSE') = 'OK';
649 FSelectedFolder := '';
650end;
651
652function TIMAPSend.StatusFolder(FolderName, Value: string): integer;
653var
654 n: integer;
655 s, t: string;
656begin
657 Result := -1;
658 Value := Uppercase(Value);
659 if IMAPcommand('STATUS "' + FolderName + '" (' + Value + ')' ) = 'OK' then
660 begin
661 ProcessLiterals;
662 for n := 0 to FFullResult.Count - 1 do
663 begin
664 s := FFullResult[n];
665// s := UpperCase(FFullResult[n]);
666 if (Pos('* ', s) = 1) and (Pos(FolderName, s) >= 1) and (Pos(Value, s) > 0 ) then
667 begin
668 t := SeparateRight(s, Value);
669 t := SeparateLeft(t, ')');
670 t := trim(t);
671 Result := StrToIntDef(t, -1);
672 Break;
673 end;
674 end;
675 end;
676end;
677
678function TIMAPSend.ExpungeFolder: Boolean;
679begin
680 Result := IMAPcommand('EXPUNGE') = 'OK';
681end;
682
683function TIMAPSend.CheckFolder: Boolean;
684begin
685 Result := IMAPcommand('CHECK') = 'OK';
686end;
687
688function TIMAPSend.AppendMess(ToFolder: string; const Mess: TStrings): Boolean;
689begin
690 Result := IMAPuploadCommand('APPEND "' + ToFolder + '"', Mess) = 'OK';
691end;
692
693function TIMAPSend.DeleteMess(MessID: integer): boolean;
694var
695 s: string;
696begin
697 s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (\Deleted)';
698 if FUID then
699 s := 'UID ' + s;
700 Result := IMAPcommand(s) = 'OK';
701end;
702
703function TIMAPSend.FetchMess(MessID: integer; const Mess: TStrings): Boolean;
704var
705 s: string;
706begin
707 s := 'FETCH ' + IntToStr(MessID) + ' (RFC822)';
708 if FUID then
709 s := 'UID ' + s;
710 Result := IMAPcommand(s) = 'OK';
711 ParseMess(Mess);
712end;
713
714function TIMAPSend.FetchHeader(MessID: integer; const Headers: TStrings): Boolean;
715var
716 s: string;
717begin
718 s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.HEADER)';
719 if FUID then
720 s := 'UID ' + s;
721 Result := IMAPcommand(s) = 'OK';
722 ParseMess(Headers);
723end;
724
725function TIMAPSend.MessageSize(MessID: integer): integer;
726var
727 n: integer;
728 s, t: string;
729begin
730 Result := -1;
731 s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.SIZE)';
732 if FUID then
733 s := 'UID ' + s;
734 if IMAPcommand(s) = 'OK' then
735 begin
736 ProcessLiterals;
737 for n := 0 to FFullResult.Count - 1 do
738 begin
739 s := UpperCase(FFullResult[n]);
740 if (Pos('* ', s) = 1) and (Pos('RFC822.SIZE', s) > 0 ) then
741 begin
742 t := SeparateRight(s, 'RFC822.SIZE ');
743 t := Trim(SeparateLeft(t, ')'));
744 t := Trim(SeparateLeft(t, ' '));
745 Result := StrToIntDef(t, -1);
746 Break;
747 end;
748 end;
749 end;
750end;
751
752function TIMAPSend.CopyMess(MessID: integer; ToFolder: string): Boolean;
753var
754 s: string;
755begin
756 s := 'COPY ' + IntToStr(MessID) + ' "' + ToFolder + '"';
757 if FUID then
758 s := 'UID ' + s;
759 Result := IMAPcommand(s) = 'OK';
760end;
761
762function TIMAPSend.SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
763var
764 s: string;
765begin
766 s := 'SEARCH ' + Criteria;
767 if FUID then
768 s := 'UID ' + s;
769 Result := IMAPcommand(s) = 'OK';
770 ParseSearch(FoundMess);
771end;
772
773function TIMAPSend.SetFlagsMess(MessID: integer; Flags: string): Boolean;
774var
775 s: string;
776begin
777 s := 'STORE ' + IntToStr(MessID) + ' FLAGS.SILENT (' + Flags + ')';
778 if FUID then
779 s := 'UID ' + s;
780 Result := IMAPcommand(s) = 'OK';
781end;
782
783function TIMAPSend.AddFlagsMess(MessID: integer; Flags: string): Boolean;
784var
785 s: string;
786begin
787 s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (' + Flags + ')';
788 if FUID then
789 s := 'UID ' + s;
790 Result := IMAPcommand(s) = 'OK';
791end;
792
793function TIMAPSend.DelFlagsMess(MessID: integer; Flags: string): Boolean;
794var
795 s: string;
796begin
797 s := 'STORE ' + IntToStr(MessID) + ' -FLAGS.SILENT (' + Flags + ')';
798 if FUID then
799 s := 'UID ' + s;
800 Result := IMAPcommand(s) = 'OK';
801end;
802
803function TIMAPSend.GetFlagsMess(MessID: integer; var Flags: string): Boolean;
804var
805 s: string;
806 n: integer;
807begin
808 Flags := '';
809 s := 'FETCH ' + IntToStr(MessID) + ' (FLAGS)';
810 if FUID then
811 s := 'UID ' + s;
812 Result := IMAPcommand(s) = 'OK';
813 ProcessLiterals;
814 for n := 0 to FFullResult.Count - 1 do
815 begin
816 s := uppercase(FFullResult[n]);
817 if (Pos('* ', s) = 1) and (Pos('FLAGS', s) > 0 ) then
818 begin
819 s := SeparateRight(s, 'FLAGS');
820 s := Separateright(s, '(');
821 Flags := Trim(SeparateLeft(s, ')'));
822 end;
823 end;
824end;
825
826function TIMAPSend.StartTLS: Boolean;
827begin
828 Result := False;
829 if FindCap('STARTTLS') <> '' then
830 begin
831 if IMAPcommand('STARTTLS') = 'OK' then
832 begin
833 Fsock.SSLDoConnect;
834 Result := FSock.LastError = 0;
835 end;
836 end;
837end;
838
839//Paul Buskermolen <p.buskermolen@pinkroccade.com>
840function TIMAPSend.GetUID(MessID: integer; var UID : Integer): boolean;
841var
842 s, sUid: string;
843 n: integer;
844begin
845 sUID := '';
846 s := 'FETCH ' + IntToStr(MessID) + ' UID';
847 Result := IMAPcommand(s) = 'OK';
848 ProcessLiterals;
849 for n := 0 to FFullResult.Count - 1 do
850 begin
851 s := uppercase(FFullResult[n]);
852 if Pos('FETCH (UID', s) >= 1 then
853 begin
854 s := Separateright(s, '(UID ');
855 sUID := Trim(SeparateLeft(s, ')'));
856 end;
857 end;
858 UID := StrToIntDef(sUID, 0);
859end;
860
861{==============================================================================}
862
863end.
Note: See TracBrowser for help on using the repository browser.