Mail::Thread - Perl implementation of JWZ's mail threading algorithm

    use Mail::Thread;
    my $threader = new Mail::Thread (@messages);

    $threader->thread;

    dump_em($_,0) for $threader->rootset;

    sub dump_em {
        my ($self, $level) = @_;
        print ' \\-> ' x $level;
        if ($self->message) {
            print $self->message->head->get("Subject") , "\n";
        } else {
            print "[ Message $self not available ]\n";
        }
        dump_em($self->child, $level+1) if $self->child;
        dump_em($self->next, $level) if $self->next;
    }

 # order by subject line
 $container->order_children( sub {
    sort { $a->topmost->message->subject cmp $b->topmost->message->subject } @_
  } );

package Mail::Thread;

use 5.00503;
use strict;
use vars qw($VERSION $debug $noprune $nosubject);
sub debug (@) { print @_ if $debug }
use Email::Abstract;

$VERSION = '2.55';

sub new {
    my $self = shift;
    return bless {
        messages => [ @_ ],
        id_table => {},
        rootset  => []
    }, $self;
}

sub _get_hdr {
    my ($class, $msg, $hdr) = @_;
    Email::Abstract->get_header($msg, $hdr) || '';
}

sub _uniq {
    my %seen;
    return grep { !$seen{$_}++ } @_;
}

sub _references {
    my $class = shift;
    my $msg = shift;
    my @references = ($class->_get_hdr($msg, "References") =~ /<([^>]+)>/g);
    my $foo = $class->_get_hdr($msg,"In-Reply-To");
    chomp $foo;
    $foo =~ s/.*?<([^>]+)>.*/$1/;
    push @references, $foo
      if $foo =~ /^\S+\@\S+$/ and (!@references || $references[-1] ne $foo);
    return _uniq(@references);
}

sub _msgid {
    my ($class, $msg) = @_;
    my $id= $msg->isa("Mail::Message") ? $msg->messageId :
            $class->_get_hdr($msg, "Message-ID");
    die "attempt to thread message with no id" unless $id;
    chomp $id;
    $id =~ s/^<([^>]+)>.*/$1/; # We expect this not to have <>s
    return $id;
}

sub rootset { @{$_[0]{rootset}} }

sub _dump {
    for (@_) {
        print "\n$_ (";
        print $_->messageid.") [".$_->subject."] has father ".eval{$_->parent};
        print ", child ".eval{$_->child}." and sibling ".eval{$_->next};
        print "\n";
        for my $tag (qw(parent child next)) {
            die "I am my own $tag!" if (eval "\$_->$tag") eq $_;
        }
    }
}

sub _group_set_bysubject {
    my $self = shift;
    my $root = $self->_container_class->new( 'fakeroot' );
    $root->set_children( $self->rootset );

    my %subject;
    for (my $walk = $root->child; $walk; $walk = $walk->next) {
        my $sub = $walk->topmost->simple_subject or next;
        # Add this container to the hash if:
        # - There is no container in the hash with this subject, or
        # - This one is a dummy container and the old one is not: the dummy
        #   one is more interesting as a root, so put it in the hash instead.
        # - The container in the table has a "Re:" version of this subject,
        #   and this container has a non-"Re:" version of this subject.
        #   The non-re version is the more interesting of the two.

        my $old = $subject{$sub};
        if (!$old ||
            (!$walk->message && !$old->message) ||
            ($old->message && $old->isreply &&
             $walk->message && !$walk->isreply)) {
            $subject{$sub} = $walk;
        }
    }
    return unless %subject;

    # %subject is now populated with one entry for each subject which
    # occurs in the root set.  Now iterate over the root set, and
    # gather together the difference.

    my ($prev, $walk, $rest);
    for ($walk = $root->child, $rest = eval{ $walk->next };
         $walk;
         $prev = $walk, $walk = $rest, $rest = eval { $rest->next }) {
        my $subj = $walk->topmost->simple_subject or next;
        my $old = $subject{$subj};
        next if $old == $walk;

        # Remove the "second" message from the root set
        if (!$prev) { $root->child( $walk->next ) }
        else        { $prev->next( $walk->next ) }
        $walk->next(undef);

        if (!$old->message && !$walk->message) {
            # They're both dummies; merge them.
            $old->add_child( $_ ) for $walk->children;
        }
        elsif (!$old->message || # old is empty, or
               ($walk->message &&
                $walk->isreply && # walk has reply, and old doesn't
                !$old->isreply)) {
            # Make this message be a child of the other.
            $old->add_child( $walk );
        }
        else {
            # Make the old and new messages be children of a dummy
            # container.
            my $new = $self->_container_class->new( $old->messageid );
            $old->messageid( 'subject dummy' );
            $new->message( $old->message );
            $old->message( undef );
            $new->add_child( $_ ) for $old->children;
            $old->add_child( $walk );
            $old->add_child( $new );
        }
        # we've done a merge, so keep the same `prev' next time around.
        $walk = $prev;
    }

    # repopulate the rootset from our fake one
    @{$self->{rootset}} = $root->children;
    $root->remove_child($_) for $self->rootset;
}

sub thread {
    my $self = shift;
    $self->_setup();
    $self->{rootset} = [ grep { !$_->parent } values %{$self->{id_table}} ];

    unless ($noprune) {
        my $fakeroot = $self->_container_class->new( 'fakeroot' );
        $fakeroot->set_children( $self->rootset );
        $self->_prune_empties($fakeroot, 0);
        my @kids = @{$self->{rootset}} = $fakeroot->children;
        $fakeroot->remove_child($_) for $fakeroot->children;
    }

    $self->_group_set_bysubject() unless $nosubject;
    $self->_finish();
}

sub _finish {
    my $self = shift;
    delete $self->{id_table};
    delete $self->{seen};
    delete $self->{seen};
}

sub _get_cont_for_id {
    my $self = shift;
    my $id = shift;
    my $cont;
    debug "Looking for a container for $id\n";
    if ($cont = $self->{id_table}{$id}) {
        debug "  Found an existing container for $id, ", $cont->subject,"\n";
    } else {
        debug "  Creating something new to hold $id\n";
        $cont = $self->_container_class->new($id);
        $self->{id_table}{$id} = $cont;
    }
    return $cont;
}

sub _container_class { "Mail::Thread::Container" }

sub _setup {
    my $self = shift;

    # 1.  For each message
    for my $message (@{$self->{messages}}) {
      $self->_add_message($message);
    }

    debug "\nThe final table:\n";
    if ($Mail::Thread::debug) {
        _dump( values %{$self->{id_table}} );
    }
}

sub _add_message {
    my ($self, $message) = @_;

    debug "\n\nLooking at ".$self->_msgid($message)."\n";
    # A. if id_table...
    my $this_container = $self->_get_cont_for_id($self->_msgid($message));
    $this_container->message($message);
    debug "  [".$this_container->subject."]\n----\n";

    # B. For each element in the message's References field:
    my @refs = $self->_references($message);
    debug " Now looking at its references: @refs\n";

    my $prev;
    for my $ref (@refs) {
        debug "   Looking at reference $ref\n";
        # Find a Container object for the given Message-ID
        my $container = $self->_get_cont_for_id($ref);

        # Link the References field's Containers together in the
        # order implied by the References header
        # * If they are already linked don't change the existing links
        # * Do not add a link if adding that link would introduce
        #   a loop...

        if ($prev &&
            !$container->parent &&  # already linked
            !$container->has_descendent($prev) # would loop
           ) {
            $prev->add_child($container);
        }
        $prev = $container;
    }

    # C. Set the parent of this message to be the last element in
    # References...
    if ($prev &&
        !$this_container->has_descendent($prev) # would loop
       ) {
        $prev->add_child($this_container)
    }

    debug "Done with this message!\n----\n";
    if ($debug) {
        _dump( values %{$self->{id_table}} );
    }

    if (0) {
        # Note that at all times the various 'parent' and 'child'
        # fields must be kept inter-consistent
        for my $c (values %{ $self->{id_table} }) {
            if ($c->parent && !grep { $c == $_ } $c->parent->children) {
                die "$c dysfunctional!\n";
            }
        }
    }
}

sub _prune_empties {
    my $self = shift;
    my $cont = shift;
    my $level = shift;

    do { debug "Stuffed!"; return () } if $self->{seen}{$cont}++;
    debug " "x$level;
    debug "Looking at ".$cont->messageid."\n";

    my ($walk, $prev, $next);
    for ($walk = $cont->child, $next = eval { $walk->next };
         $walk;
         $prev = $walk, $walk = $next, $next = eval { $walk->next } ) {

       my @children = $walk->children;
       debug " "x$level;
       debug "Looking at ".$walk->messageid." ".@children." children\n";

       if (!$walk->message and !@children) {
           debug "No message and no children - killing\n";
           if (!$prev) { $cont->child($walk->next) }
           else        { $prev->next($walk->next)  }
           $walk = $prev;
           next;
       }

       if (!$walk->message and @children and (@children == 1 or $walk->parent)) {
           debug "Promoting the children\n";
           my $kids = $walk->child;
           if (!$prev) { $cont->child($kids) }
           else        { $prev->next($kids)  }

           $_->parent($walk->parent) for @children;
           $children[-1]->next( $walk->next );

           $next = $kids;
           $walk = $prev;
           next;
       }

       if ($walk->child) {
           debug "recursing on down\n";
           $self->_prune_empties($walk, $level + 1);
       }
    }
}

sub order {
    my $self = shift;
    my $ordersub = shift;

    # make a fake root
    my $root = $self->_container_class->new( 'fakeroot' );
    $root->add_child( $_ ) for @{ $self->{rootset} };

    # sort it
    $root->order_children( $ordersub );

    # and untangle it
    my @kids = $root->children;
    $self->{rootset} = \@kids;
    $root->remove_child($_) for @kids;
}

package Mail::Thread::Container;
use Carp qw(carp confess croak cluck);

sub new { my $self = shift; bless { id => shift }, $self; }

sub message { $_[0]->{message} = $_[1] if @_ == 2; $_[0]->{message} }
sub child   { $_[0]->{child}   = $_[1] if @_ == 2; $_[0]->{child}   }
sub parent  { $_[0]->{parent}  = $_[1] if @_ == 2; $_[0]->{parent}  }
sub next    { $_[0]->{next}    = $_[1] if @_ == 2; $_[0]->{next}    }
sub messageid { $_[0]->{id}      = $_[1] if @_ == 2; $_[0]->{id}      }
sub subject { $_[0]->header("subject") }
sub header { $_[0]->message and eval { my $s = Email::Abstract->get_header($_[0]->message, $_[1] ) || ''; chomp $s; $s; } }


sub topmost {
    my $self = shift;

    return $self if $self->message;
    my $kid = eval { $self->child->topmost };
    return $kid if $kid;
    my $sib = eval { $self->next->topmost };
    return $sib if $sib;
    return;
}

sub isreply {
    my $self = shift;
    my $subject = $self->subject or return;
    $subject =~ m{^re:\s+}i;
}

sub simple_subject {
    my $self = shift;
    my $subject = $self->subject;
    $subject =~ s/^re:\s+//gi;
    $subject;
}

sub add_child {
    my ($self, $child) = @_;
    croak "Cowardly refusing to become my own parent: $self"
      if $self == $child;

    if (grep { $_ == $child } $self->children) {
        # All is potentially correct with the world
        $child->parent($self);
        return;
    }

    $child->parent->remove_child($child) if $child->parent;

    $child->next($self->child);
    $self->child($child);
    $child->parent($self);
}

sub remove_child {
    my ($self, $child) = @_;
    return unless $self->child;
    if ($self->child == $child) {  # First one's easy.
        $self->child($child->next);
        $child->next(undef);
        $child->parent(undef);
        return;
    }

    my $x = $self->child;
    my $prev = $x;
    while ($x = $x->next) {
        if ($x == $child) {
            $prev->next($x->next); # Unlink x
            $x->next(undef);
            $x->parent(undef);     # Deparent it
            return;
        }
        $prev = $x;
    }
    # oddly, we can get here
    $child->next(undef);
    $child->parent(undef);
}

sub has_descendent {
    my $self = shift;
    my $child = shift;
    die "Assertion failed: $child" unless eval {$child->isa("Mail::Thread::Container")};
    my $there = 0;
    $self->recurse_down(sub { $there = 1 if $_[0] == $child });

    return $there;
}

sub children {
    my $self = shift;
    my @children;
    my $visitor = $self->child;
    while ($visitor) { push @children, $visitor; $visitor = $visitor->next }
    return @children;
}

sub set_children {
    my $self = shift;
    my $walk = $self->child( shift );
    while (@_) { $walk = $walk->next( shift ) }
    $walk->next(undef) if $walk;
}


sub order_children {
    my $self = shift;
    my $ordersub = shift;

    return unless $ordersub;

    my $sub = sub {
        my $cont = shift;
        my @children = $cont->children;
        return if @children < 2;
        $cont->set_children( $ordersub->( @children ) );
    };
    $self->iterate_down( undef, $sub );
    undef $sub;
}

sub recurse_down {
    my %seen;
    my $do_it_all;
    $do_it_all = sub {
        my $self = shift;
        my $callback = shift;
        $seen{$self}++;
        $callback->($self);

        if ($self->next && $seen{$self->next}) { $self->next(undef) }
        $do_it_all->($self->next, $callback)  if $self->next;
        if ($self->child && $seen{$self->child}) { $self->child(undef) }
        $do_it_all->($self->child, $callback) if $self->child;

    };
    $do_it_all->(@_);
    undef $do_it_all;
}

sub iterate_down {
    my $self = shift;
    my ($before, $after) = @_;

    my %seen;
    my $walk = $self;
    my $depth = 0;
    my @visited;
    while ($walk) {
        push @visited, [ $walk, $depth ];
        $before->($walk, $depth) if $before;

        # spot/break loops
        $seen{$walk}++;
        if ($walk->child && $seen{$walk->child}) { $walk->child(undef) }
        if ($walk->next  && $seen{$walk->next})  { $walk->next(undef)  }

        my $next;
        # go down, or across
        if ($walk->child) { $next = $walk->child; ++$depth }
        else              { $next = $walk->next }

        # no next?  look up
        if (!$next) {
            my $up = $walk;
            while ($up && !$next) {
                $up = $up->parent;  --$depth;
                $next = $up->next if $up;
            }
        }
        $walk = $next;
    }
    return unless $after;
    while (@visited) { $after->(@{ pop @visited }) }
}

1;
__END__