File Coverage

blib/lib/Mail/Box/Thread/Manager.pm
Criterion Covered Total %
statement 143 176 81.2
branch 34 62 54.8
condition 16 33 48.4
subroutine 26 30 86.6
pod 14 15 93.3
total 233 316 73.7


line stmt bran cond sub pod time code
1             # Copyrights 2001-2023 by [Mark Overmeer].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.03.
5             # This code is part of distribution Mail-Box. Meta-POD processed with
6             # OODoc into POD and HTML manual-pages. See README.md
7             # Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
8              
9             package Mail::Box::Thread::Manager;
10 4     4   936 use vars '$VERSION';
  4         10  
  4         297  
11             $VERSION = '3.010';
12              
13 4     4   25 use base 'Mail::Reporter';
  4         8  
  4         627  
14              
15 4     4   33 use strict;
  4         7  
  4         114  
16 4     4   23 use warnings;
  4         19  
  4         154  
17              
18 4     4   30 use Carp;
  4         7  
  4         313  
19 4     4   2043 use Mail::Box::Thread::Node;
  4         15  
  4         125  
20 4     4   1878 use Mail::Message::Dummy;
  4         12  
  4         8872  
21              
22              
23             sub init($)
24 3     3 0 115 { my ($self, $args) = @_;
25              
26             $self->{MBTM_manager} = $args->{manager}
27 3 50       48 or croak "Need a manager to work with.";
28              
29 3   50     25 $self->{MBTM_thread_body}= $args->{thread_body}|| 0;
30 3   50     17 $self->{MBTM_thread_type}= $args->{thread_type}||'Mail::Box::Thread::Node';
31 3   50     17 $self->{MBTM_dummy_type} = $args->{dummy_type} ||'Mail::Message::Dummy';
32              
33 3   50     85 for($args->{timespan} || '3 days')
34 3 50       43 { $self->{MBTM_timespan} = $_ eq 'EVER' ? 'EVER'
35             : Mail::Box->timespan2seconds($_);
36             }
37              
38 3   50     16 for($args->{window} || 10)
39 3 50       19 { $self->{MBTM_window} = $_ eq 'ALL' ? 'ALL' : $_;
40             }
41 3         17 $self;
42             }
43              
44             #-------------------------------------------
45              
46 2     2 1 4 sub folders() { values %{shift->{MBTM_folders}} }
  2         16  
47              
48              
49             sub includeFolder(@)
50 3     3 1 6 { my $self = shift;
51              
52 3         10 foreach my $folder (@_)
53 3 50 33     36 { croak "Not a folder: $folder"
54             unless ref $folder && $folder->isa('Mail::Box');
55              
56 3         16 my $name = $folder->name;
57 3 50       135 next if exists $self->{MBTM_folders}{$name};
58              
59 3         17 $self->{MBTM_folders}{$name} = $folder;
60 3         26 foreach my $msg ($folder->messages)
61 135 100       468 { $self->inThread($msg) unless $msg->head->isDelayed;
62             }
63             }
64              
65 3         16 $self;
66             }
67              
68              
69             sub removeFolder(@)
70 3     3 1 7 { my $self = shift;
71              
72 3         9 foreach my $folder (@_)
73 3 50 33     39 { croak "Not a folder: $folder"
74             unless ref $folder && $folder->isa('Mail::Box');
75              
76 3         22 my $name = $folder->name;
77 3 50       18 next unless exists $self->{MBTM_folders}{$name};
78              
79 3         9 delete $self->{MBTM_folders}{$name};
80              
81             $_->headIsRead && $self->outThread($_)
82 3   33     12 foreach $folder->messages;
83              
84 3         14 $self->{MBTM_cleanup_needed} = 1;
85             }
86              
87 3         13 $self;
88             }
89              
90             #-------------------------------------------
91              
92             sub thread($)
93 4     4 1 408 { my ($self, $message) = @_;
94 4         19 my $msgid = $message->messageId;
95 4         56 my $timestamp = $message->timestamp;
96              
97 4         9053 $self->_process_delayed_nodes;
98 4   50     18 my $thread = $self->{MBTM_ids}{$msgid} || return;
99              
100 4         9 my @missing;
101             $thread->recurse
102 10     10   15 ( sub { my $node = shift;
103 10 50       22 push @missing, $node->messageId if $node->isDummy;
104 10         30 1;
105             }
106 4         32 );
107              
108 4 50       34 return $thread unless @missing;
109              
110 0         0 foreach my $folder ($self->folders)
111             {
112             # Pull-in all messages received after this-one, from any folder.
113 0         0 my @now_missing = $folder->scanForMessages
114             ( $msgid
115             , [ @missing ]
116             , $timestamp - 3600 # some clocks are wrong.
117             , 0
118             );
119              
120 0 0       0 if(@now_missing != @missing)
121 0         0 { $self->_process_delayed_nodes;
122 0 0       0 last unless @now_missing;
123 0         0 @missing = @now_missing;
124             }
125             }
126              
127 0         0 $thread;
128             }
129              
130              
131             sub threadStart($)
132 3     3 1 1040 { my ($self, $message) = @_;
133              
134 3   50     15 my $thread = $self->thread($message) || return;
135              
136 3         12 while(my $parent = $thread->repliedTo)
137 2 100       8 { unless($parent->isDummy)
138             { # Message already found, no special action to be taken.
139 1         2 $thread = $parent;
140 1         3 next;
141             }
142              
143 1         9 foreach ($self->folders)
144 1         4 { my $message = $thread->message;
145             my $timespan = $message->isDummy ? 'ALL'
146 1 50       8 : $message->timestamp - $self->{MBTM_timespan};
147              
148             last unless $_->scanForMessages
149             ( $thread->messageId, $parent->messageId
150             , $timespan, $self->{MBTM_window}
151 1 50       17 );
152             }
153              
154 1         5 $self->_process_delayed_nodes;
155 1         5 $thread = $parent;
156             }
157              
158 3         14 $thread;
159             }
160              
161              
162             sub all()
163 0     0 1 0 { my $self = shift;
164 0         0 $_->find('not-existing') for $self->folders;
165 0         0 $self->known;
166             }
167              
168              
169             sub sortedAll(@)
170 1     1 1 2 { my $self = shift;
171 1         3 $_->find('not-existing') for $self->folders;
172 1         7 $self->sortedKnown(@_);
173             }
174              
175              
176             sub known()
177 3     3 1 64 { my $self = shift->_process_delayed_nodes->_cleanup;
178 3         6 grep {!defined $_->repliedTo} values %{$self->{MBTM_ids}};
  100         189  
  3         22  
179             }
180              
181              
182             sub sortedKnown(;$$)
183 2     2 1 7 { my $self = shift;
184 2   50 56   22 my $prepare = shift || sub {shift->startTimeEstimate||0};
  56         115  
185 2   50 190   18 my $compare = shift || sub {(shift) <=> (shift)};
  190         331  
186            
187             # Special care for double keys.
188 2         4 my %value;
189 2         11 push @{$value{$prepare->($_)}}, $_ for $self->known;
  56         2926  
190 2         39 map @{$value{$_}}, sort {$compare->($a, $b)} keys %value;
  54         127  
  190         259  
191             }
192              
193             # When a whole folder is removed, many threads can become existing
194             # only of dummies. They must be removed.
195              
196             sub _cleanup()
197 3     3   5 { my $self = shift;
198 3 50       13 return $self unless $self->{MBTM_cleanup_needed};
199              
200 0         0 foreach ($self->known)
201 0         0 { my $real = 0;
202             $_->recurse
203 0     0   0 ( sub { my $node = shift;
204 0         0 foreach ($node->messages)
205 0 0       0 { next if $_->isDummy;
206 0         0 $real = 1;
207 0         0 return 0;
208             }
209 0         0 1;
210             }
211 0         0 );
212              
213 0 0       0 next if $real;
214              
215             $_->recurse
216 0     0   0 ( sub { my $node = shift;
217 0         0 my $msgid = $node->messageId;
218 0         0 delete $self->{MBTM_ids}{$msgid};
219 0         0 1;
220             }
221 0         0 );
222             }
223              
224 0         0 delete $self->{MBTM_cleanup_needed};
225 0         0 $self;
226             }
227              
228             #-------------------------------------------
229              
230             sub toBeThreaded($@)
231 45     45 1 86 { my ($self, $folder) = (shift, shift);
232 45 50       100 return $self unless exists $self->{MBTM_folders}{$folder->name};
233 45         117 $self->inThread($_) foreach @_;
234 45         110 $self;
235             }
236              
237              
238             sub toBeUnthreaded($@)
239 0     0 1 0 { my ($self, $folder) = (shift, shift);
240 0 0       0 return $self unless exists $self->{MBTM_folders}{$folder->name};
241 0         0 $self->outThread($_) foreach @_;
242 0         0 $self;
243             }
244              
245              
246             sub inThread($)
247 135     135 1 730 { my ($self, $message) = @_;
248 135         256 my $msgid = $message->messageId;
249 135         713 my $node = $self->{MBTM_ids}{$msgid};
250              
251             # Already known, but might reside in many folders.
252 135 50       246 if($node) { $node->addMessage($message) }
  0         0  
253             else
254             { $node = Mail::Box::Thread::Node->new(message => $message
255             , msgid => $msgid, dummy_type => $self->{MBTM_dummy_type}
256 135         506 );
257 135         429 $self->{MBTM_ids}{$msgid} = $node;
258             }
259              
260 135         304 $self->{MBTM_delayed}{$msgid} = $node; # removes doubles.
261             }
262              
263             # The relation between nodes is delayed, to avoid that first
264             # dummy nodes have to be made, and then immediately upgrades
265             # to real nodes. So: at first we inventory what we have, and
266             # then build thread-lists.
267              
268             sub _process_delayed_nodes()
269 8     8   19 { my $self = shift;
270 8 100       42 return $self unless $self->{MBTM_delayed};
271              
272 3         6 foreach my $node (values %{$self->{MBTM_delayed}})
  3         26  
273             { $self->_process_delayed_message($node, $_)
274 135         311 foreach $node->message;
275             }
276              
277 3         34 delete $self->{MBTM_delayed};
278 3         12 $self;
279             }
280              
281             sub _process_delayed_message($$)
282 135     135   216 { my ($self, $node, $message) = @_;
283 135         286 my $msgid = $message->messageId;
284              
285             # will force parsing of head when not done yet.
286 135 50       608 my $head = $message->head or return $self;
287              
288 135         1869 my $replies;
289 135 100       258 if(my $irt = $head->get('in-reply-to'))
290 54         908 { for($irt =~ m/\<(\S+\@\S+)\>/)
291 54         1697 { my $msgid = $1;
292 54   66     209 $replies = $self->{MBTM_ids}{$msgid} || $self->createDummy($msgid);
293             }
294             }
295              
296 135         842 my @refs;
297 135 100       263 if(my $refs = $head->get('references'))
298 54         822 { while($refs =~ s/\<(\S+\@\S+)\>//s)
299 84         2748 { my $msgid = $1;
300 84   66     353 push @refs, $self->{MBTM_ids}{$msgid} || $self->createDummy($msgid);
301             }
302             }
303              
304             # Handle the `In-Reply-To' message header.
305             # This is the most secure relationship.
306              
307 135 100       814 if($replies)
308 54 50       127 { $node->follows($replies, 'REPLY')
309             and $replies->followedBy($node);
310             }
311              
312             # Handle the `References' message header.
313             # The (ordered) list of message-IDs give an impression where this
314             # message resides in the thread. There is a little less certainty
315             # that the list is correctly ordered and correctly maintained.
316              
317 135 100       280 if(@refs)
318 54 50       174 { push @refs, $node unless $refs[-1] eq $node;
319 54         99 my $from = shift @refs;
320              
321 54         110 while(my $to = shift @refs)
322 84 50       168 { $to->follows($from, 'REFERENCE')
323             and $from->followedBy($to);
324 84         213 $from = $to;
325             }
326             }
327              
328 135         320 $self;
329             }
330              
331             #-------------------------------------------
332              
333              
334             sub outThread($)
335 135     135 1 807 { my ($self, $message) = @_;
336 135         246 my $msgid = $message->messageId;
337 135 100       674 my $node = $self->{MBTM_ids}{$msgid} or return $message;
338              
339             $node->{MBTM_messages}
340 134         174 = [ grep {$_ ne $message} @{$node->{MBTM_messages}} ];
  0         0  
  134         258  
341              
342 134         343 $self;
343             }
344              
345             #-------------------------------------------
346              
347              
348             sub createDummy($)
349 15     15 1 35 { my ($self, $msgid) = @_;
350             $self->{MBTM_ids}{$msgid} = $self->{MBTM_thread_type}->new
351 15         56 (msgid => $msgid, dummy_type => $self->{MBTM_dummy_type});
352             }
353              
354             #-------------------------------------------
355              
356              
357             1;