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
  24 sub new {
  25         return bless {
  26                 messages => $_[1],
  27                 id_table => {},
  28                 rootset  => []
  29         }, $_[0];
  30 }
  31
  32 sub rootset { @{$_[0]{rootset}} }
  33
  34 sub thread {
  35         my $self = shift;
  36         $self->_setup();
  37         $self->{rootset} = [
  38                         grep { !$_->{parent} } values %{$self->{id_table}} ];
  39         $self->_finish();
  40 }
  41
  42 sub _finish {
  43         my $self = shift;
  44         delete $self->{id_table};
  45         delete $self->{seen};
  46 }
  47
  48 sub _get_cont_for_id ($$) {
  49         my ($self, $mid) = @_;
  50         $self->{id_table}{$mid} ||= PublicInbox::SearchThread::Msg->new($mid);
  51 }
  52
  53 sub _setup {
  54         my ($self) = @_;
  55
  56         _add_message($self, $_) foreach @{$self->{messages}};
  57 }
  58
  59 sub _add_message ($$) {
  60         my ($self, $smsg) = @_;
  61
  62         # A. if id_table...
  63         my $this = _get_cont_for_id($self, $smsg->{mid});
  64         $this->{smsg} = $smsg;
  65
  66         # B. For each element in the message's References field:
  67         my $prev;
  68         if (defined(my $refs = $smsg->{references})) {
  69                 foreach my $ref ($refs =~ m/<([^>]+)>/g) {
  70                         # Find a Container object for the given Message-ID
  71                         my $cont = _get_cont_for_id($self, $ref);
  72
  73                         # Link the References field's Containers together in
  74                         # the order implied by the References header
  75                         #
  76                         # * If they are already linked don't change the
  77                         #   existing links
  78                         # * Do not add a link if adding that link would
  79                         #   introduce a loop...
  80                         if ($prev &&
  81                                 !$cont->{parent} &&  # already linked
  82                                 !$cont->has_descendent($prev) # would loop
  83                            ) {
  84                                 $prev->add_child($cont);
  85                         }
  86                         $prev = $cont;
  87                 }
  88         }
  89
  90         # C. Set the parent of this message to be the last element in
  91         # References...
  92         if ($prev && !$this->has_descendent($prev)) { # would loop
  93                 $prev->add_child($this)
  94         }
  95 }
  96
  97 sub order {
  98         my $self = shift;
  99         my $ordersub = shift;
 100
 101         # make a fake root
 102         my $root = _get_cont_for_id($self, 'fakeroot');
 103         $root->add_child( $_ ) for @{ $self->{rootset} };
 104
 105         # sort it
 106         $root->order_children( $ordersub );
 107
 108         # and untangle it
 109         my $kids = $root->children;
 110         $self->{rootset} = $kids;
 111         $root->remove_child($_) for @$kids;
 112 }
 113
 114 package PublicInbox::SearchThread::Msg;
 115 use Carp qw(croak);
 116 use Scalar::Util qw(weaken);
 117
 118 sub new { my $self = shift; bless { id => shift }, $self; }
 119
 120 sub add_child {
 121         my ($self, $child) = @_;
 122         croak "Cowardly refusing to become my own parent: $self"
 123           if $self == $child;
 124
 125         if (grep { $_ == $child } @{$self->children}) {
 126                 # All is potentially correct with the world
 127                 weaken($child->{parent} = $self);
 128                 return;
 129         }
 130
 131         my $parent = $child->{parent};
 132         remove_child($parent, $child) if $parent;
 133
 134         $child->{next} = $self->{child};
 135         $self->{child} = $child;
 136         weaken($child->{parent} = $self);
 137 }
 138
 139 sub remove_child {
 140         my ($self, $child) = @_;
 141
 142         my $x = $self->{child} or return;
 143         if ($x == $child) {  # First one's easy.
 144                 $self->{child} = $child->{next};
 145                 $child->{parent} = $child->{next} = undef;
 146                 return;
 147         }
 148
 149         my $prev = $x;
 150         while ($x = $x->{next}) {
 151                 if ($x == $child) {
 152                         $prev->{next} = $x->{next}; # Unlink x
 153                         $x->{next} = $x->{parent} = undef; # Deparent it
 154                         return;
 155                 }
 156                 $prev = $x;
 157         }
 158         # oddly, we can get here
 159         $child->{next} = $child->{parent} = undef;
 160 }
 161
 162 sub has_descendent {
 163         my $self = shift;
 164         my $child = shift;
 165         die "Assertion failed: $child" unless eval {$child};
 166         my $there = 0;
 167         $self->recurse_down(sub { $there = 1 if $_[0] == $child });
 168
 169         return $there;
 170 }
 171
 172 sub children {
 173         my $self = shift;
 174         my @children;
 175         my $visitor = $self->{child};
 176         while ($visitor) {
 177                 push @children, $visitor;
 178                 $visitor = $visitor->{next};
 179         }
 180         \@children;
 181 }
 182
 183 sub set_children {
 184         my ($self, $children) = @_;
 185         my $walk = $self->{child} = shift @$children;
 186         do {
 187                 $walk = $walk->{next} = shift @$children;
 188         } while ($walk);
 189 }
 190
 191 sub order_children {
 192         my $self = shift;
 193         my $ordersub = shift;
 194
 195         return unless $ordersub;
 196
 197         my $sub = sub {
 198                 my $cont = shift;
 199                 my $children = $cont->children;
 200                 return if @$children < 2;
 201                 $cont->set_children( $ordersub->( $children ) );
 202         };
 203         $self->iterate_down( undef, $sub );
 204         undef $sub;
 205 }
 206
 207 # non-recursive version of recurse_down to avoid stack depth warnings
 208 sub recurse_down {
 209         my ($self, $callback) = @_;
 210         my %seen;
 211         my @q = ($self);
 212         while (my $cont = shift @q) {
 213                 $seen{$cont}++;
 214                 $callback->($cont);
 215
 216                 if (my $next = $cont->{next}) {
 217                         if ($seen{$next}) {
 218                                 $cont->{next} = undef;
 219                         } else {
 220                                 push @q, $next;
 221                         }
 222                 }
 223                 if (my $child = $cont->{child}) {
 224                         if ($seen{$child}) {
 225                                 $cont->{child} = undef;
 226                         } else {
 227                                 push @q, $child;
 228                         }
 229                 }
 230         }
 231 }
 232
 233 sub iterate_down {
 234         my $self = shift;
 235         my ($before, $after) = @_;
 236
 237         my %seen;
 238         my $walk = $self;
 239         my $depth = 0;
 240         my @visited;
 241         while ($walk) {
 242                 push @visited, [ $walk, $depth ];
 243                 $before->($walk, $depth) if $before;
 244
 245                 # spot/break loops
 246                 $seen{$walk}++;
 247
 248                 my $child = $walk->{child};
 249                 if ($child && $seen{$child}) {
 250                         $walk->{child} = $child = undef;
 251                 }
 252
 253                 my $next = $walk->{next};
 254                 if ($next && $seen{$next}) {
 255                         $walk->{next} = $next = undef;
 256                 }
 257
 258                 # go down, or across
 259                 if ($child) {
 260                         $next = $child;
 261                         ++$depth;
 262                 }
 263
 264                 # no next?  look up
 265                 if (!$next) {
 266                         my $up = $walk;
 267                         while ($up && !$next) {
 268                                 $up = $up->{parent};
 269                                 --$depth;
 270                                 $next = $up->{next} if $up;
 271                         }
 272                 }
 273                 $walk = $next;
 274         }
 275         return unless $after;
 276         while (@visited) { $after->(@{ pop @visited }) }
 277 }
 278
 279 1;