1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299 | ------------------------------------------------------------------------------
-- G N A T C O L L --
-- --
-- Copyright (C) 2006-2020, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
------------------------------------------------------------------------------
-- This package handles mailboxes that contain one or more email messages
with Ada.Containers.Indefinite_Doubly_Linked_Lists;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Finalization;
with GNATCOLL.Email.Parser;
with GNAT.Strings;
with GNATCOLL.VFS;
package GNATCOLL.Email.Mailboxes is
-- ??? Would be nice to have a function to write back a message in a
-- mailbox (with proper message separators).
---------------
-- Mailboxes --
---------------
type Mailbox is abstract tagged limited private;
-- This type describes a mailbox, which contains several email messages in
-- some defined format. See the children of this type for the various
-- supported formats.
-- This mailbox can be iterated: to get all messages, you would do the
-- following:
-- Box : Mbox;
--
-- Open (Box, File_Contents)
--
-- Curs : Cursor'Class := First (Box);
-- while Has_Element (Curs) loop
-- Get_Message (Curs, Box, Msg);
-- if Msg /= Null_Message then
-- -- test above is in case of parsing error
-- ...
-- Next (Curs, Box);
-- end loop;
type Message_Factory is access procedure (Str : String; Msg : out Message);
-- Builds a message from a string. It should return Null_Message if the
-- message could not be parsed.
-- You can provide a different function if you simply want to get the text
-- of all messages (for instance for a search function), and do not need to
-- waste time actually parsing the message.
type Cursor is abstract tagged private;
-- An iterator over the contents of a mailbox
function First (Self : Mailbox) return Cursor'Class is abstract;
-- Return a cursor to iterator over all messages of the mailbox
procedure Set_Parser
(Self : in out Cursor;
Factory : Message_Factory := Email.Parser.Parse'Access);
-- Set the factory used to create the messages parsed from the mailbox.
-- It can be used to limit which fields should be parsed, whether the body
-- should be returned,...
function Has_Element (Self : Cursor) return Boolean is abstract;
-- True if Self points to a message in the mailbox, False if past the last
-- message.
procedure Get_Message
(Self : in out Cursor;
Box : Mailbox'Class;
Msg : out Message) is abstract;
-- Return the current message.
-- If there is no such message or the message could not be parsed, returns
-- Null_Message.
-- The message is generated from the text representing the mailbox by
-- calling the factory.
procedure Next (Self : in out Cursor; Box : Mailbox'Class) is abstract;
-- Moves to the next message in Self
--------------------
-- Unix mailboxes --
--------------------
type Mbox is new Mailbox with private;
-- This type describes a mail box in the traditional format used by Unix
-- systems. Messages are appended one after another, separated by a blank
-- line and a line starting with "From ".
overriding function First (Self : Mbox) return Cursor'Class;
-- Return an instance of Mbox_Cursor
type Destructor is access procedure (S : in out GNAT.Strings.String_Access);
-- Free the memory associated with the "Fp" parameter given to Open
procedure Free_String (Str : in out GNAT.Strings.String_Access);
procedure Open
(Self : in out Mbox;
Fp : access String;
On_Close : Destructor := Free_String'Access);
-- Initializes the internal data for the mailbox. This procedure must be
-- called by the various *Open functions below, but doesn't need to be
-- called by the user.
-- No copy of Fp is made. On_Close (if defined) is called when the mbox no
-- longer needs access to Fp. As a result, you can either give control over
-- Fp to the mailbox (and leave the default value for On_Close), or keep
-- control of the string, and pass null to On_Close.
procedure Open
(Self : in out Mbox;
Filename : GNATCOLL.VFS.Virtual_File);
-- Same as Open, but takes care of opening the file.
-- If the file could not be open, Name_Error is raised.
type Mbox_Cursor is new Cursor with private;
overriding function Has_Element (Self : Mbox_Cursor) return Boolean;
overriding procedure Next
(Self : in out Mbox_Cursor;
Box : Mailbox'Class);
overriding procedure Get_Message
(Self : in out Mbox_Cursor;
Box : Mailbox'Class;
Msg : out Message);
-- See inherited documentation
-------------------------
-- In-Memory mailboxes --
-------------------------
type Stored_Mailbox is new Mailbox with private;
-- This type represents the contents of a mailbox in memory. All messages
-- that are part of a file mailbox are read and kept in memory. This
-- provides a convenient way to keep messages in memory while they are in
-- use, and in particular provides ways to sort them.
-- This type is limited since it would be costly to copy instances of a
-- mailbox otherwise (duplicating all messages in memory).
procedure Store
(Self : out Stored_Mailbox;
Box : in out Mailbox'Class;
Factory : Message_Factory := Email.Parser.Parse'Access);
procedure Store
(Self : out Stored_Mailbox;
Box : in out Mailbox'Class;
Factory : Message_Factory := Email.Parser.Parse'Access;
From : Cursor'Class);
-- Parse a mailbox and store all its messages in memory.
-- All messages previously in Self are kept.
-- Box must already have been Open'ed.
-- The second version allows you to skip messages if needed
procedure Append (Self : in out Stored_Mailbox; Msg : Message);
-- Appends a new message to Self. The current sorting order is not
-- preserved, and you should call Sort_* again after you have added one or
-- more messages.
procedure Thread_Messages (Self : in out Stored_Mailbox);
-- Sort all messages in Self by threads. This preserves the sort order.
-- This does nothing if Self is already threaded.
procedure Remove_Threads (Stored : in out Stored_Mailbox);
-- Removing all threading information from Stored. The mailbox is no
-- longer sorted as a result.
function Is_Threaded (Self : Stored_Mailbox) return Boolean;
-- Whether Self is sorted by threads
procedure Sort_By_Date (Self : in out Stored_Mailbox);
-- Sort all messages by Date. This preserves threading information if
-- available.
type Stored_Mailbox_Cursor is new Cursor with private;
-- Iterate over the contents of a mailbox
overriding function First (Self : Stored_Mailbox) return Cursor'Class;
function First
(Self : Stored_Mailbox; Recurse : Boolean)
return Stored_Mailbox_Cursor'Class;
-- Starts iteration over all elements in Self, in the order they were
-- sorted.
-- If Recurse is False and messages have been sorted by threads, this will
-- only iterate over the root message of each thread. Use First_In_Thread
-- to iterate recursively over each thread. Traversal is depth-first.
-- If Recurse is True, then all messages will eventually be returned.
-- The iterator becomes invalid when you call one of the Sort_* functions.
-- The first version of First returns a cursor that iterates not
-- recursively.
function First_In_Thread
(Self : Stored_Mailbox; Parent : Stored_Mailbox_Cursor'Class)
return Stored_Mailbox_Cursor'Class;
-- Return the first child of Msg in its thread. If the threads are
-- organized as:
-- Msg1 (thread level 1)
-- |_ Msg1.1 (thread level 2)
-- |_ Msg1.1.1 (thread level 3)
-- |_ Msg1.2 (thread level 2)
-- Msg2 (thread level 1);
-- and Msg1 is passed in argument, then the iterator will return
-- Msg1.1 and Msg1.2, not Msg1.1.1 nor Msg2.
-- This function always returns an empty iterator if the mailbox is not
-- sorted by threads.
overriding procedure Next
(Self : in out Stored_Mailbox_Cursor;
Box : Mailbox'Class);
-- See inherited documentation
overriding procedure Get_Message
(Self : in out Stored_Mailbox_Cursor;
Box : Mailbox'Class;
Msg : out Message);
function Get_Thread_Level (Iter : Stored_Mailbox_Cursor) return Positive;
-- Return the current message in the mailbox, or Null_Message if there are
-- no more messages. See the small drawing above for the meaning of
-- Thread_Level. If the mailbox has not been sorted by threads, the level
-- is always 1.
overriding function Has_Element
(Self : Stored_Mailbox_Cursor) return Boolean;
-- Whether calling Next on Iter will return a Message
private
type Mailbox is abstract new Ada.Finalization.Limited_Controlled with record
null;
end record;
type Cursor is abstract tagged record
Factory : Message_Factory := Email.Parser.Parse'Access;
end record;
type Mbox_Cursor is new Cursor with record
Start, Stop : Integer;
Max : Integer;
Current : Message;
-- Cache the current message
end record;
overriding procedure Finalize (Self : in out Mailbox);
pragma Finalize_Storage_Only (Mailbox);
type Mbox is new Mailbox with record
Fp : GNAT.Strings.String_Access;
On_Close : Destructor;
Previous_Line_Empty : Boolean := True;
end record;
overriding procedure Finalize (Self : in out Mbox);
-- See inherited documentation
type Abstract_Message_Info is abstract tagged record
Msg : Message;
end record;
package Message_Info_List is new
Ada.Containers.Indefinite_Doubly_Linked_Lists
(Abstract_Message_Info'Class);
type Message_Info is new Abstract_Message_Info with record
Children : Message_Info_List.List;
end record;
type Sort_Order is (Sort_None, Sort_Date);
type Stored_Mailbox is new Mailbox with record
Messages : Message_Info_List.List; -- Contains Message_Info
Sorted_By : Sort_Order := Sort_None;
Threaded : Boolean := False;
end record;
package Cursor_List is new Ada.Containers.Doubly_Linked_Lists
(Message_Info_List.Cursor, Message_Info_List."=");
type Stored_Mailbox_Cursor is new Cursor with record
Cursors : Cursor_List.List;
Recurse : Boolean;
Thread_Level : Integer;
end record;
-- If the specified thread level is 0, all messages are returned.
-- Otherwise, only the messages at the right level.
end GNATCOLL.Email.Mailboxes;
|