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