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

Last change on this file was 2, checked in by chronos, 12 years ago
  • Přidáno: Základní kostra projektu.
  • Přidáno: Knihovna synapse.
File size: 26.0 KB
Line 
1{==============================================================================|
2| Project : Ararat Synapse | 002.005.003 |
3|==============================================================================|
4| Content: IMAP4rev1 client |
5|==============================================================================|
6| Copyright (c)1999-2012, 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-2012. |
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
55{$IFDEF UNICODE}
56 {$WARN IMPLICIT_STRING_CAST OFF}
57 {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
58{$ENDIF}
59
60unit imapsend;
61
62interface
63
64uses
65 SysUtils, Classes,
66 blcksock, synautil;
67
68const
69 cIMAPProtocol = '143';
70
71type
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;
93 function ReadResult: string;
94 function AuthLogin: Boolean;
95 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.}
107 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.}
111 function IMAPuploadCommand(Value: string; const Data:TStrings): string;
112
113 {:Call CAPABILITY command and fill IMAPcap property by new values.}
114 function Capability: Boolean;
115
116 {:Connect to IMAP server and do login to this server. This command begin
117 session.}
118 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!}
122 function Logout: Boolean;
123
124 {:Do NOOP. It is for prevent disconnect by timeout.}
125 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.}
129 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.}
134 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.}
139 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.}
144 function ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
145
146 {:Create a new folder.}
147 function CreateFolder(FolderName: string): Boolean;
148
149 {:Delete a folder.}
150 function DeleteFolder(FolderName: string): Boolean;
151
152 {:Rename folder names.}
153 function RenameFolder(FolderName, NewFolderName: string): Boolean;
154
155 {:Subscribe folder.}
156 function SubscribeFolder(FolderName: string): Boolean;
157
158 {:Unsubscribe folder.}
159 function UnsubscribeFolder(FolderName: string): Boolean;
160
161 {:Select folder.}
162 function SelectFolder(FolderName: string): Boolean;
163
164 {:Select folder, but only for reading. Any changes are not allowed!}
165 function SelectROFolder(FolderName: string): Boolean;
166
167 {:Close a folder. (end of Selected state)}
168 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.)}
174 function StatusFolder(FolderName, Value: string): integer;
175
176 {:Hardly delete all messages marked as 'deleted' in current selected folder.}
177 function ExpungeFolder: Boolean;
178
179 {:Touch to folder. (use as update status of folder, etc.)}
180 function CheckFolder: Boolean;
181
182 {:Append given message to specified folder.}
183 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)}
188 function DeleteMess(MessID: integer): boolean;
189
190 {:Get full message from specified message in selected folder.}
191 function FetchMess(MessID: integer; const Mess: TStrings): Boolean;
192
193 {:Get message headers only from specified message in selected folder.}
194 function FetchHeader(MessID: integer; const Headers: TStrings): Boolean;
195
196 {:Return message size of specified message from current selected folder.}
197 function MessageSize(MessID: integer): integer;
198
199 {:Copy message from current selected folder to another folder.}
200 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!).}
205 function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
206
207 {:Sets flags of message from current selected folder.}
208 function SetFlagsMess(MessID: integer; Flags: string): Boolean;
209
210 {:Gets flags of message from current selected folder.}
211 function GetFlagsMess(MessID: integer; var Flags: string): Boolean;
212
213 {:Add flags to message's flags.}
214 function AddFlagsMess(MessID: integer; Flags: string): Boolean;
215
216 {:Remove flags from message's flags.}
217 function DelFlagsMess(MessID: integer; Flags: string): Boolean;
218
219 {:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
220 function StartTLS: Boolean;
221
222 {:return UID of requested message ID.}
223 function GetUID(MessID: integer; var UID : Integer): Boolean;
224
225 {:Try to find given capabily in capabilty string returned from IMAP server.}
226 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
269implementation
270
271constructor TIMAPSend.Create;
272begin
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;
291end;
292
293destructor TIMAPSend.Destroy;
294begin
295 FSock.Free;
296 FIMAPcap.Free;
297 FFullResult.Free;
298 inherited Destroy;
299end;
300
301
302function TIMAPSend.ReadResult: string;
303var
304 s: string;
305 x, l: integer;
306begin
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, ' ')));
334end;
335
336procedure TIMAPSend.ProcessLiterals;
337var
338 l: TStringList;
339 n, x: integer;
340 b: integer;
341 s: string;
342begin
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;
375end;
376
377function TIMAPSend.IMAPcommand(Value: string): string;
378begin
379 Inc(FTagCommand);
380 FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + CRLF);
381 Result := ReadResult;
382end;
383
384function TIMAPSend.IMAPuploadCommand(Value: string; const Data:TStrings): string;
385var
386 l: integer;
387begin
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;
394end;
395
396procedure TIMAPSend.ParseMess(Value:TStrings);
397var
398 n: integer;
399begin
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;
407end;
408
409procedure TIMAPSend.ParseFolderList(Value:TStrings);
410var
411 n, x: integer;
412 s: string;
413begin
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;
432end;
433
434procedure TIMAPSend.ParseSelect;
435var
436 n: integer;
437 s, t: string;
438begin
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;
465end;
466
467procedure TIMAPSend.ParseSearch(Value:TStrings);
468var
469 n: integer;
470 s: string;
471begin
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;
484end;
485
486function TIMAPSend.FindCap(const Value: string): string;
487var
488 n: Integer;
489 s: string;
490begin
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;
499end;
500
501function TIMAPSend.AuthLogin: Boolean;
502begin
503 Result := IMAPcommand('LOGIN "' + FUsername + '" "' + FPassword + '"') = 'OK';
504end;
505
506function TIMAPSend.Connect: Boolean;
507begin
508 FSock.CloseSocket;
509 FSock.Bind(FIPInterface, cAnyPort);
510 if FSock.LastError = 0 then
511 FSock.Connect(FTargetHost, FTargetPort);
512 if FSock.LastError = 0 then
513 if FFullSSL then
514 FSock.SSLDoConnect;
515 Result := FSock.LastError = 0;
516end;
517
518function TIMAPSend.Capability: Boolean;
519var
520 n: Integer;
521 s, t: string;
522begin
523 Result := False;
524 FIMAPcap.Clear;
525 s := IMAPcommand('CAPABILITY');
526 if s = 'OK' then
527 begin
528 ProcessLiterals;
529 for n := 0 to FFullResult.Count - 1 do
530 if Pos('* CAPABILITY ', FFullResult[n]) = 1 then
531 begin
532 s := Trim(SeparateRight(FFullResult[n], '* CAPABILITY '));
533 while not (s = '') do
534 begin
535 t := Trim(separateleft(s, ' '));
536 s := Trim(separateright(s, ' '));
537 if s = t then
538 s := '';
539 FIMAPcap.Add(t);
540 end;
541 end;
542 Result := True;
543 end;
544end;
545
546function TIMAPSend.Login: Boolean;
547var
548 s: string;
549begin
550 FSelectedFolder := '';
551 FSelectedCount := 0;
552 FSelectedRecent := 0;
553 FSelectedUIDvalidity := 0;
554 Result := False;
555 FAuthDone := False;
556 if not Connect then
557 Exit;
558 s := FSock.RecvString(FTimeout);
559 if Pos('* PREAUTH', s) = 1 then
560 FAuthDone := True
561 else
562 if Pos('* OK', s) = 1 then
563 FAuthDone := False
564 else
565 Exit;
566 if Capability then
567 begin
568 if Findcap('IMAP4rev1') = '' then
569 Exit;
570 if FAutoTLS and (Findcap('STARTTLS') <> '') then
571 if StartTLS then
572 Capability;
573 end;
574 Result := AuthLogin;
575end;
576
577function TIMAPSend.Logout: Boolean;
578begin
579 Result := IMAPcommand('LOGOUT') = 'OK';
580 FSelectedFolder := '';
581 FSock.CloseSocket;
582end;
583
584function TIMAPSend.NoOp: Boolean;
585begin
586 Result := IMAPcommand('NOOP') = 'OK';
587end;
588
589function TIMAPSend.List(FromFolder: string; const FolderList: TStrings): Boolean;
590begin
591 Result := IMAPcommand('LIST "' + FromFolder + '" *') = 'OK';
592 ParseFolderList(FolderList);
593end;
594
595function TIMAPSend.ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;
596begin
597 Result := IMAPcommand('LIST "' + FromFolder + '" "' + Search +'"') = 'OK';
598 ParseFolderList(FolderList);
599end;
600
601function TIMAPSend.ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;
602begin
603 Result := IMAPcommand('LSUB "' + FromFolder + '" *') = 'OK';
604 ParseFolderList(FolderList);
605end;
606
607function TIMAPSend.ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
608begin
609 Result := IMAPcommand('LSUB "' + FromFolder + '" "' + Search +'"') = 'OK';
610 ParseFolderList(FolderList);
611end;
612
613function TIMAPSend.CreateFolder(FolderName: string): Boolean;
614begin
615 Result := IMAPcommand('CREATE "' + FolderName + '"') = 'OK';
616end;
617
618function TIMAPSend.DeleteFolder(FolderName: string): Boolean;
619begin
620 Result := IMAPcommand('DELETE "' + FolderName + '"') = 'OK';
621end;
622
623function TIMAPSend.RenameFolder(FolderName, NewFolderName: string): Boolean;
624begin
625 Result := IMAPcommand('RENAME "' + FolderName + '" "' + NewFolderName + '"') = 'OK';
626end;
627
628function TIMAPSend.SubscribeFolder(FolderName: string): Boolean;
629begin
630 Result := IMAPcommand('SUBSCRIBE "' + FolderName + '"') = 'OK';
631end;
632
633function TIMAPSend.UnsubscribeFolder(FolderName: string): Boolean;
634begin
635 Result := IMAPcommand('UNSUBSCRIBE "' + FolderName + '"') = 'OK';
636end;
637
638function TIMAPSend.SelectFolder(FolderName: string): Boolean;
639begin
640 Result := IMAPcommand('SELECT "' + FolderName + '"') = 'OK';
641 FSelectedFolder := FolderName;
642 ParseSelect;
643end;
644
645function TIMAPSend.SelectROFolder(FolderName: string): Boolean;
646begin
647 Result := IMAPcommand('EXAMINE "' + FolderName + '"') = 'OK';
648 FSelectedFolder := FolderName;
649 ParseSelect;
650end;
651
652function TIMAPSend.CloseFolder: Boolean;
653begin
654 Result := IMAPcommand('CLOSE') = 'OK';
655 FSelectedFolder := '';
656end;
657
658function TIMAPSend.StatusFolder(FolderName, Value: string): integer;
659var
660 n: integer;
661 s, t: string;
662begin
663 Result := -1;
664 Value := Uppercase(Value);
665 if IMAPcommand('STATUS "' + FolderName + '" (' + Value + ')' ) = 'OK' then
666 begin
667 ProcessLiterals;
668 for n := 0 to FFullResult.Count - 1 do
669 begin
670 s := FFullResult[n];
671// s := UpperCase(FFullResult[n]);
672 if (Pos('* ', s) = 1) and (Pos(FolderName, s) >= 1) and (Pos(Value, s) > 0 ) then
673 begin
674 t := SeparateRight(s, Value);
675 t := SeparateLeft(t, ')');
676 t := trim(t);
677 Result := StrToIntDef(t, -1);
678 Break;
679 end;
680 end;
681 end;
682end;
683
684function TIMAPSend.ExpungeFolder: Boolean;
685begin
686 Result := IMAPcommand('EXPUNGE') = 'OK';
687end;
688
689function TIMAPSend.CheckFolder: Boolean;
690begin
691 Result := IMAPcommand('CHECK') = 'OK';
692end;
693
694function TIMAPSend.AppendMess(ToFolder: string; const Mess: TStrings): Boolean;
695begin
696 Result := IMAPuploadCommand('APPEND "' + ToFolder + '"', Mess) = 'OK';
697end;
698
699function TIMAPSend.DeleteMess(MessID: integer): boolean;
700var
701 s: string;
702begin
703 s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (\Deleted)';
704 if FUID then
705 s := 'UID ' + s;
706 Result := IMAPcommand(s) = 'OK';
707end;
708
709function TIMAPSend.FetchMess(MessID: integer; const Mess: TStrings): Boolean;
710var
711 s: string;
712begin
713 s := 'FETCH ' + IntToStr(MessID) + ' (RFC822)';
714 if FUID then
715 s := 'UID ' + s;
716 Result := IMAPcommand(s) = 'OK';
717 ParseMess(Mess);
718end;
719
720function TIMAPSend.FetchHeader(MessID: integer; const Headers: TStrings): Boolean;
721var
722 s: string;
723begin
724 s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.HEADER)';
725 if FUID then
726 s := 'UID ' + s;
727 Result := IMAPcommand(s) = 'OK';
728 ParseMess(Headers);
729end;
730
731function TIMAPSend.MessageSize(MessID: integer): integer;
732var
733 n: integer;
734 s, t: string;
735begin
736 Result := -1;
737 s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.SIZE)';
738 if FUID then
739 s := 'UID ' + s;
740 if IMAPcommand(s) = 'OK' then
741 begin
742 ProcessLiterals;
743 for n := 0 to FFullResult.Count - 1 do
744 begin
745 s := UpperCase(FFullResult[n]);
746 if (Pos('* ', s) = 1) and (Pos('RFC822.SIZE', s) > 0 ) then
747 begin
748 t := SeparateRight(s, 'RFC822.SIZE ');
749 t := Trim(SeparateLeft(t, ')'));
750 t := Trim(SeparateLeft(t, ' '));
751 Result := StrToIntDef(t, -1);
752 Break;
753 end;
754 end;
755 end;
756end;
757
758function TIMAPSend.CopyMess(MessID: integer; ToFolder: string): Boolean;
759var
760 s: string;
761begin
762 s := 'COPY ' + IntToStr(MessID) + ' "' + ToFolder + '"';
763 if FUID then
764 s := 'UID ' + s;
765 Result := IMAPcommand(s) = 'OK';
766end;
767
768function TIMAPSend.SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
769var
770 s: string;
771begin
772 s := 'SEARCH ' + Criteria;
773 if FUID then
774 s := 'UID ' + s;
775 Result := IMAPcommand(s) = 'OK';
776 ParseSearch(FoundMess);
777end;
778
779function TIMAPSend.SetFlagsMess(MessID: integer; Flags: string): Boolean;
780var
781 s: string;
782begin
783 s := 'STORE ' + IntToStr(MessID) + ' FLAGS.SILENT (' + Flags + ')';
784 if FUID then
785 s := 'UID ' + s;
786 Result := IMAPcommand(s) = 'OK';
787end;
788
789function TIMAPSend.AddFlagsMess(MessID: integer; Flags: string): Boolean;
790var
791 s: string;
792begin
793 s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (' + Flags + ')';
794 if FUID then
795 s := 'UID ' + s;
796 Result := IMAPcommand(s) = 'OK';
797end;
798
799function TIMAPSend.DelFlagsMess(MessID: integer; Flags: string): Boolean;
800var
801 s: string;
802begin
803 s := 'STORE ' + IntToStr(MessID) + ' -FLAGS.SILENT (' + Flags + ')';
804 if FUID then
805 s := 'UID ' + s;
806 Result := IMAPcommand(s) = 'OK';
807end;
808
809function TIMAPSend.GetFlagsMess(MessID: integer; var Flags: string): Boolean;
810var
811 s: string;
812 n: integer;
813begin
814 Flags := '';
815 s := 'FETCH ' + IntToStr(MessID) + ' (FLAGS)';
816 if FUID then
817 s := 'UID ' + s;
818 Result := IMAPcommand(s) = 'OK';
819 ProcessLiterals;
820 for n := 0 to FFullResult.Count - 1 do
821 begin
822 s := uppercase(FFullResult[n]);
823 if (Pos('* ', s) = 1) and (Pos('FLAGS', s) > 0 ) then
824 begin
825 s := SeparateRight(s, 'FLAGS');
826 s := Separateright(s, '(');
827 Flags := Trim(SeparateLeft(s, ')'));
828 end;
829 end;
830end;
831
832function TIMAPSend.StartTLS: Boolean;
833begin
834 Result := False;
835 if FindCap('STARTTLS') <> '' then
836 begin
837 if IMAPcommand('STARTTLS') = 'OK' then
838 begin
839 Fsock.SSLDoConnect;
840 Result := FSock.LastError = 0;
841 end;
842 end;
843end;
844
845//Paul Buskermolen <p.buskermolen@pinkroccade.com>
846function TIMAPSend.GetUID(MessID: integer; var UID : Integer): boolean;
847var
848 s, sUid: string;
849 n: integer;
850begin
851 sUID := '';
852 s := 'FETCH ' + IntToStr(MessID) + ' UID';
853 Result := IMAPcommand(s) = 'OK';
854 ProcessLiterals;
855 for n := 0 to FFullResult.Count - 1 do
856 begin
857 s := uppercase(FFullResult[n]);
858 if Pos('FETCH (UID', s) >= 1 then
859 begin
860 s := Separateright(s, '(UID ');
861 sUID := Trim(SeparateLeft(s, ')'));
862 end;
863 end;
864 UID := StrToIntDef(sUID, 0);
865end;
866
867{==============================================================================}
868
869end.
Note: See TracBrowser for help on using the repository browser.