lib/PublicInbox/SearchThread.pm

   1 # This library is free software; you can redistribute it and/or modify
   2 # it under the same terms as Perl itself.
   3 #
   4 # This license differs from the rest of public-inbox
   5 #
   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.
  11 #
  12 # This includes fixes from several open bugs for Mail::Thread
  13 #
  14 # Avoid circular references
  15 # - https://rt.cpan.org/Public/Bug/Display.html?id=22817
  16 #
  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;
  21 use strict;
  22 use warnings;
  23 use Email::Abstract;
  24
  25 sub new {
  26         return bless {
  27                 messages => $_[1],
  28                 id_table => {},
  29                 rootset  => []
  30         }, $_[0];
  31 }
  32
  33 sub _get_hdr {
  34         my ($class, $msg, $hdr) = @_;
  35         Email::Abstract->get_header($msg, $hdr) || '';
  36 }
  37
  38 sub _uniq {
  39         my %seen;
  40         return grep { !$seen{$_}++ } @_;
  41 }
  42
  43 sub _references {
  44         my $class = shift;
  45         my $msg = shift;
  46         my @references = ($class->_get_hdr($msg, "References") =~ /<([^>]+)>/g);
  47         my $foo = $class->_get_hdr($msg, "In-Reply-To");
  48         chomp $foo;
  49         $foo =~ s/.*?<([^>]+)>.*/$1/;
  50         push @references, $foo
  51           if $foo =~ /^\S+\@\S+$/ && (!@references || $references[-1] ne $foo);
  52         return _uniq(@references);
  53 }
  54
  55 sub _msgid {
  56         my ($class, $msg) = @_;
  57         my $id = $class->_get_hdr($msg, "Message-ID");
  58         die "attempt to thread message with no id" unless $id;
  59         chomp $id;
  60         $id =~ s/^<([^>]+)>.*/$1/; # We expect this not to have <>s
  61         return $id;
  62 }
  63
  64 sub rootset { @{$_[0]{rootset}} }
  65
  66 sub thread {
  67         my $self = shift;
  68         $self->_setup();
  69         $self->{rootset} = [
  70                         grep { !$_->{parent} } values %{$self->{id_table}} ];
  71         $self->_finish();
  72 }
  73
  74 sub _finish {
  75         my $self = shift;
  76         delete $self->{id_table};
  77         delete $self->{seen};
  78 }
  79
  80 sub _get_cont_for_id {
  81         my $self = shift;
  82         my $id = shift;
  83         $self->{id_table}{$id} ||= $self->_container_class->new($id);
  84 }
  85
  86 sub _container_class { 'PublicInbox::SearchThread::Container' }
  87
  88 sub _setup {
  89         my ($self) = @_;
  90
  91         _add_message($self, $_) foreach @{$self->{messages}};
  92 }
  93
  94 sub _add_message ($$) {
  95         my ($self, $message) = @_;
  96
  97         # A. if id_table...
  98         my $this_container = $self->_get_cont_for_id($self->_msgid($message));
  99         $this_container->{message} = $message;
 100
 101         # B. For each element in the message's References field:
 102         my @refs = $self->_references($message);
 103
 104         my $prev;
 105         for my $ref (@refs) {
 106                 # Find a Container object for the given Message-ID
 107                 my $container = $self->_get_cont_for_id($ref);
 108
 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
 113                 #   a loop...
 114
 115                 if ($prev &&
 116                         !$container->{parent} &&  # already linked
 117                         !$container->has_descendent($prev) # would loop
 118                    ) {
 119                         $prev->add_child($container);
 120                 }
 121                 $prev = $container;
 122         }
 123
 124         # C. Set the parent of this message to be the last element in
 125         # References...
 126         if ($prev &&
 127                 !$this_container->has_descendent($prev) # would loop
 128            ) {
 129                 $prev->add_child($this_container)
 130         }
 131 }
 132
 133 sub order {
 134         my $self = shift;
 135         my $ordersub = shift;
 136
 137         # make a fake root
 138         my $root = $self->_container_class->new( 'fakeroot' );
 139         $root->add_child( $_ ) for @{ $self->{rootset} };
 140
 141         # sort it
 142         $root->order_children( $ordersub );
 143
 144         # and untangle it
 145         my $kids = $root->children;
 146         $self->{rootset} = $kids;
 147         $root->remove_child($_) for @$kids;
 148 }
 149
 150 package PublicInbox::SearchThread::Container;
 151 use Carp qw(croak);
 152 use Scalar::Util qw(weaken);
 153
 154 sub new { my $self = shift; bless { id => shift }, $self; }
 155
 156 sub message { $_[0]->{message} }
 157 sub child { $_[0]->{child} }
 158 sub next { $_[0]->{next} }
 159 sub messageid { $_[0]->{id} }
 160
 161 sub add_child {
 162         my ($self, $child) = @_;
 163         croak "Cowardly refusing to become my own parent: $self"
 164           if $self == $child;
 165
 166         if (grep { $_ == $child } @{$self->children}) {
 167                 # All is potentially correct with the world
 168                 weaken($child->{parent} = $self);
 169                 return;
 170         }
 171
 172         my $parent = $child->{parent};
 173         remove_child($parent, $child) if $parent;
 174
 175         $child->{next} = $self->{child};
 176         $self->{child} = $child;
 177         weaken($child->{parent} = $self);
 178 }
 179
 180 sub remove_child {
 181         my ($self, $child) = @_;
 182
 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;
 187                 return;
 188         }
 189
 190         my $prev = $x;
 191         while ($x = $x->{next}) {
 192                 if ($x == $child) {
 193                         $prev->{next} = $x->{next}; # Unlink x
 194                         $x->{next} = $x->{parent} = undef; # Deparent it
 195                         return;
 196                 }
 197                 $prev = $x;
 198         }
 199         # oddly, we can get here
 200         $child->{next} = $child->{parent} = undef;
 201 }
 202
 203 sub has_descendent {
 204         my $self = shift;
 205         my $child = shift;
 206         die "Assertion failed: $child" unless eval {$child};
 207         my $there = 0;
 208         $self->recurse_down(sub { $there = 1 if $_[0] == $child });
 209
 210         return $there;
 211 }
 212
 213 sub children {
 214         my $self = shift;
 215         my @children;
 216         my $visitor = $self->{child};
 217         while ($visitor) {
 218                 push @children, $visitor;
 219                 $visitor = $visitor->{next};
 220         }
 221         \@children;
 222 }
 223
 224 sub set_children {
 225         my ($self, $children) = @_;
 226         my $walk = $self->{child} = shift @$children;
 227         do {
 228                 $walk = $walk->{next} = shift @$children;
 229         } while ($walk);
 230 }
 231
 232 sub order_children {
 233         my $self = shift;
 234         my $ordersub = shift;
 235
 236         return unless $ordersub;
 237
 238         my $sub = sub {
 239                 my $cont = shift;
 240                 my $children = $cont->children;
 241                 return if @$children < 2;
 242                 $cont->set_children( $ordersub->( $children ) );
 243         };
 244         $self->iterate_down( undef, $sub );
 245         undef $sub;
 246 }
 247
 248 # non-recursive version of recurse_down to avoid stack depth warnings
 249 sub recurse_down {
 250         my ($self, $callback) = @_;
 251         my %seen;
 252         my @q = ($self);
 253         while (my $cont = shift @q) {
 254                 $seen{$cont}++;
 255                 $callback->($cont);
 256
 257                 if (my $next = $cont->{next}) {
 258                         if ($seen{$next}) {
 259                                 $cont->{next} = undef;
 260                         } else {
 261                                 push @q, $next;
 262                         }
 263                 }
 264                 if (my $child = $cont->{child}) {
 265                         if ($seen{$child}) {
 266                                 $cont->{child} = undef;
 267                         } else {
 268                                 push @q, $child;
 269                         }
 270                 }
 271         }
 272 }
 273
 274 sub iterate_down {
 275         my $self = shift;
 276         my ($before, $after) = @_;
 277
 278         my %seen;
 279         my $walk = $self;
 280         my $depth = 0;
 281         my @visited;
 282         while ($walk) {
 283                 push @visited, [ $walk, $depth ];
 284                 $before->($walk, $depth) if $before;
 285
 286                 # spot/break loops
 287                 $seen{$walk}++;
 288
 289                 my $child = $walk->{child};
 290                 if ($child && $seen{$child}) {
 291                         $walk->{child} = $child = undef;
 292                 }
 293
 294                 my $next = $walk->{next};
 295                 if ($next && $seen{$next}) {
 296                         $walk->{next} = $next = undef;
 297                 }
 298
 299                 # go down, or across
 300                 if ($child) {
 301                         $next = $child;
 302                         ++$depth;
 303                 }
 304
 305                 # no next?  look up
 306                 if (!$next) {
 307                         my $up = $walk;
 308                         while ($up && !$next) {
 309                                 $up = $up->{parent};
 310                                 --$depth;
 311                                 $next = $up->{next} if $up;
 312                         }
 313                 }
 314                 $walk = $next;
 315         }
 316         return unless $after;
 317         while (@visited) { $after->(@{ pop @visited }) }
 318 }
 319
 320 1;