package Mail::Thread;
use 5.00503;
use strict;
use vars qw($VERSION $debug $noprune $nosubject);
sub debug (@) { print @_ if $debug }
$VERSION = '2.41';
sub new {
my $self = shift;
return bless {
messages => [ @_ ],
id_table => {},
rootset => []
}, $self;
}
sub _get_hdr {
my ($class, $msg, $hdr) = @_;
$msg->head->get($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}} ];
delete $self->{id_table};
delete $self->{seen};
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;
}
delete $self->{seen};
$self->_group_set_bysubject() unless $nosubject;
$self->_finish();
}
sub _finish { }
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}}) {
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";
}
}
}
}
debug "\nThe final table:\n";
if ($Mail::Thread::debug) {
_dump( values %{$self->{id_table}} );
}
}
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 { eval { my $s = $_[0]->message->head->get( $_[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__
=head1 NAME
Mail::Thread - Perl implementation of JWZ's mail threading algorithm
=head1 SYNOPSIS
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;
}
=head1 DESCRIPTION
This module implements something relatively close to Jamie Zawinski's mail
threading algorithm, as described by http://www.jwz.org/doc/threading.html.
Any deviations from the algorithm are accidental.
It's happy to be handed C<Mail::Internet> and C<Mail::Box::Message> objects,
since they're more or less the same, but nothing other than that.
=head1 METHODS
=head2 new(@messages)
Creates a new threader; requires a bunch of messages to thread.
=head2 thread
Goes away and threads the messages together.
=head2 rootset
Returns a list of C<Mail::Thread::Container>s which are not the parents
of any other message.
=head2 order($ordering_sub)
calls C<order_children> over each member of the root set, from one level higher
=head1 C<Mail::Thread::Container> methods
C<Mail::Thread::Container>s are the nodes of the thread tree. You can't just
have the ordinary messages, because we might not have the message in question.
For instance, a mailbox could contain two replies to a question that we
haven't received yet. So all "logical" messages are stuffed in containers,
whether we happen to have that container or not.
To do anything useful with the thread tree, you're going to have to recurse
around the list of C<Mail::Thread::Containers>. You do this with the following
methods:
=head2 parent
=head2 child
=head2 next
Returns the container which is the parent, child or immediate sibling
of this one, if one exists.
=head2 message
Returns the message held in this container, if we have one.
=head2 messageid
Returns the message ID for this container. This will be around whether we
have the message or not, since some other message will have referred to it
by message ID.
=head2 header( $name )
returns the named header of the contained message
=head2 subject
returns the subject line of the contained message
=head2 isreply
examines the results of ->subject and returns true if it looks like a reply
=head2 simple_subject
the simplified version of ->subject (with reply markers removed)
=head2 has_descendent($child)
Returns true if this container has the given container as a child somewhere
beneath it.
=head2 add_child($child)
Add the C<$child> as a child of oneself.
=head2 remove_child($child)
Remove the C<$child> as a child from oneself.
=head2 children
Returns a list of the B<immediate> children of this container.
=head2 set_children(@children)
set the children of a node. does not update the ->parents of the @children
=head2 order_children($ordering_sub)
Recursively reorders children according to the results of $ordering_sub
$ordering_sub is called with the containers children, and is expected to
return them in their new order.
# order by subject line
$container->order_children( sub {
sort { $a->topmost->message->subject cmp $b->topmost->message->subject } @_
} );
$ordering_sub may be omitted, in which case no ordering takes place
=head2 topmost
Walks the tree depth-first and returns the first message container found with a message attached
=head2 recurse_down($callback)
Calls the given callback on this node and B<all> of its children.
=head1 AUTHOR
Simon Cozens, E<lt>simon@kasei.comE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright 2003 by Kasei
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut