1 # This library is free software; you can redistribute it and/or modify
2 # it under the same terms as Perl itself.
4 # This license differs from the rest of public-inbox
6 # Our own jwz-style threading class based on Mail::Thread from CPAN.
7 # Mail::Thread is unmaintained and available on some distros.
8 # We also do not want pruning or subject grouping, since we want
9 # to encourage strict threading and hopefully encourage people
10 # to use proper In-Reply-To.
12 # This includes fixes from several open bugs for Mail::Thread
14 # Avoid circular references
15 # - https://rt.cpan.org/Public/Bug/Display.html?id=22817
17 # And avoid recursion in recurse_down:
18 # - https://rt.cpan.org/Ticket/Display.html?id=116727
19 # - http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=833479
20 package PublicInbox::SearchThread;
34 my ($class, $msg, $hdr) = @_;
35 Email::Abstract->get_header($msg, $hdr) || '';
40 return grep { !$seen{$_}++ } @_;
46 my @references = ($class->_get_hdr($msg, "References") =~ /<([^>]+)>/g);
47 my $foo = $class->_get_hdr($msg, "In-Reply-To");
49 $foo =~ s/.*?<([^>]+)>.*/$1/;
50 push @references, $foo
51 if $foo =~ /^\S+\@\S+$/ && (!@references || $references[-1] ne $foo);
52 return _uniq(@references);
56 my ($class, $msg) = @_;
57 my $id = $class->_get_hdr($msg, "Message-ID");
58 die "attempt to thread message with no id" unless $id;
60 $id =~ s/^<([^>]+)>.*/$1/; # We expect this not to have <>s
64 sub rootset { @{$_[0]{rootset}} }
69 $self->{rootset} = [ grep { !$_->parent } values %{$self->{id_table}} ];
75 delete $self->{id_table};
79 sub _get_cont_for_id {
82 $self->{id_table}{$id} ||= $self->_container_class->new($id);
85 sub _container_class { 'PublicInbox::SearchThread::Container' }
90 _add_message($self, $_) foreach @{$self->{messages}};
93 sub _add_message ($$) {
94 my ($self, $message) = @_;
97 my $this_container = $self->_get_cont_for_id($self->_msgid($message));
98 $this_container->message($message);
100 # B. For each element in the message's References field:
101 my @refs = $self->_references($message);
104 for my $ref (@refs) {
105 # Find a Container object for the given Message-ID
106 my $container = $self->_get_cont_for_id($ref);
108 # Link the References field's Containers together in the
109 # order implied by the References header
110 # * If they are already linked don't change the existing links
111 # * Do not add a link if adding that link would introduce
115 !$container->parent && # already linked
116 !$container->has_descendent($prev) # would loop
118 $prev->add_child($container);
123 # C. Set the parent of this message to be the last element in
126 !$this_container->has_descendent($prev) # would loop
128 $prev->add_child($this_container)
134 my $ordersub = shift;
137 my $root = $self->_container_class->new( 'fakeroot' );
138 $root->add_child( $_ ) for @{ $self->{rootset} };
141 $root->order_children( $ordersub );
144 my @kids = $root->children;
145 $self->{rootset} = \@kids;
146 $root->remove_child($_) for @kids;
149 package PublicInbox::SearchThread::Container;
151 use Scalar::Util qw(weaken);
153 sub new { my $self = shift; bless { id => shift }, $self; }
155 sub message { $_[0]->{message} = $_[1] if @_ == 2; $_[0]->{message} }
156 sub parent { @_ == 2 ? weaken($_[0]->{parent} = $_[1]) : $_[0]->{parent} }
157 sub child { $_[0]->{child} = $_[1] if @_ == 2; $_[0]->{child} }
158 sub next { $_[0]->{next} = $_[1] if @_ == 2; $_[0]->{next} }
159 sub messageid { $_[0]->{id} }
162 my ($self, $child) = @_;
163 croak "Cowardly refusing to become my own parent: $self"
166 if (grep { $_ == $child } $self->children) {
167 # All is potentially correct with the world
168 $child->parent($self);
172 $child->parent->remove_child($child) if $child->parent;
174 $child->next($self->child);
175 $self->child($child);
176 $child->parent($self);
180 my ($self, $child) = @_;
181 return unless $self->child;
182 if ($self->child == $child) { # First one's easy.
183 $self->child($child->next);
185 $child->parent(undef);
189 my $x = $self->child;
191 while ($x = $x->next) {
193 $prev->next($x->next); # Unlink x
195 $x->parent(undef); # Deparent it
200 # oddly, we can get here
202 $child->parent(undef);
208 die "Assertion failed: $child" unless eval {$child};
210 $self->recurse_down(sub { $there = 1 if $_[0] == $child });
218 my $visitor = $self->child;
220 push @children, $visitor;
221 $visitor = $visitor->next
228 my $walk = $self->child( shift );
229 while (@_) { $walk = $walk->next( shift ) }
230 $walk->next(undef) if $walk;
235 my $ordersub = shift;
237 return unless $ordersub;
241 my @children = $cont->children;
242 return if @children < 2;
243 $cont->set_children( $ordersub->( @children ) );
245 $self->iterate_down( undef, $sub );
249 # non-recursive version of recurse_down to avoid stack depth warnings
251 my ($self, $callback) = @_;
254 while (my $cont = shift @q) {
258 if (my $next = $cont->next) {
265 if (my $child = $cont->child) {
277 my ($before, $after) = @_;
284 push @visited, [ $walk, $depth ];
285 $before->($walk, $depth) if $before;
290 my $child = $walk->child;
291 if ($child && $seen{$child}) {
296 my $next = $walk->next;
297 if ($next && $seen{$next}) {
311 while ($up && !$next) {
314 $next = $up->next if $up;
319 return unless $after;
320 while (@visited) { $after->(@{ pop @visited }) }