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}} }
70 grep { !$_->{parent} } values %{$self->{id_table}} ];
76 delete $self->{id_table};
80 sub _get_cont_for_id {
83 $self->{id_table}{$id} ||= $self->_container_class->new($id);
86 sub _container_class { 'PublicInbox::SearchThread::Container' }
91 _add_message($self, $_) foreach @{$self->{messages}};
94 sub _add_message ($$) {
95 my ($self, $message) = @_;
98 my $this_container = $self->_get_cont_for_id($self->_msgid($message));
99 $this_container->{message} = $message;
101 # B. For each element in the message's References field:
102 my @refs = $self->_references($message);
105 for my $ref (@refs) {
106 # Find a Container object for the given Message-ID
107 my $container = $self->_get_cont_for_id($ref);
109 # Link the References field's Containers together in the
110 # order implied by the References header
111 # * If they are already linked don't change the existing links
112 # * Do not add a link if adding that link would introduce
116 !$container->{parent} && # already linked
117 !$container->has_descendent($prev) # would loop
119 $prev->add_child($container);
124 # C. Set the parent of this message to be the last element in
127 !$this_container->has_descendent($prev) # would loop
129 $prev->add_child($this_container)
135 my $ordersub = shift;
138 my $root = $self->_container_class->new( 'fakeroot' );
139 $root->add_child( $_ ) for @{ $self->{rootset} };
142 $root->order_children( $ordersub );
145 my $kids = $root->children;
146 $self->{rootset} = $kids;
147 $root->remove_child($_) for @$kids;
150 package PublicInbox::SearchThread::Container;
152 use Scalar::Util qw(weaken);
154 sub new { my $self = shift; bless { id => shift }, $self; }
156 sub message { $_[0]->{message} }
157 sub child { $_[0]->{child} }
158 sub next { $_[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 weaken($child->{parent} = $self);
172 my $parent = $child->{parent};
173 remove_child($parent, $child) if $parent;
175 $child->{next} = $self->{child};
176 $self->{child} = $child;
177 weaken($child->{parent} = $self);
181 my ($self, $child) = @_;
183 my $x = $self->{child} or return;
184 if ($x == $child) { # First one's easy.
185 $self->{child} = $child->{next};
186 $child->{parent} = $child->{next} = undef;
191 while ($x = $x->{next}) {
193 $prev->{next} = $x->{next}; # Unlink x
194 $x->{next} = $x->{parent} = undef; # Deparent it
199 # oddly, we can get here
200 $child->{next} = $child->{parent} = undef;
206 die "Assertion failed: $child" unless eval {$child};
208 $self->recurse_down(sub { $there = 1 if $_[0] == $child });
216 my $visitor = $self->{child};
218 push @children, $visitor;
219 $visitor = $visitor->{next};
225 my ($self, $children) = @_;
226 my $walk = $self->{child} = shift @$children;
228 $walk = $walk->{next} = shift @$children;
234 my $ordersub = shift;
236 return unless $ordersub;
240 my $children = $cont->children;
241 return if @$children < 2;
242 $cont->set_children( $ordersub->( $children ) );
244 $self->iterate_down( undef, $sub );
248 # non-recursive version of recurse_down to avoid stack depth warnings
250 my ($self, $callback) = @_;
253 while (my $cont = shift @q) {
257 if (my $next = $cont->{next}) {
259 $cont->{next} = undef;
264 if (my $child = $cont->{child}) {
266 $cont->{child} = undef;
276 my ($before, $after) = @_;
283 push @visited, [ $walk, $depth ];
284 $before->($walk, $depth) if $before;
289 my $child = $walk->{child};
290 if ($child && $seen{$child}) {
291 $walk->{child} = $child = undef;
294 my $next = $walk->{next};
295 if ($next && $seen{$next}) {
296 $walk->{next} = $next = undef;
308 while ($up && !$next) {
311 $next = $up->{next} if $up;
316 return unless $after;
317 while (@visited) { $after->(@{ pop @visited }) }