diff options
Diffstat (limited to 'fml/lib/Mail/ThreadTrack/Analyze.pm')
| -rw-r--r-- | fml/lib/Mail/ThreadTrack/Analyze.pm | 530 |
1 files changed, 530 insertions, 0 deletions
diff --git a/fml/lib/Mail/ThreadTrack/Analyze.pm b/fml/lib/Mail/ThreadTrack/Analyze.pm new file mode 100644 index 00000000..ec395f2b --- /dev/null +++ b/fml/lib/Mail/ThreadTrack/Analyze.pm @@ -0,0 +1,530 @@ +#-*- perl -*- +# +# Copyright (C) 2001 Ken'ichi Fukamachi +# All rights reserved. This program is free software; you can +# redistribute it and/or modify it under the same terms as Perl itself. +# +# $FML: @template.pm,v 1.1 2001/08/07 12:23:48 fukachan Exp $ +# + +package Mail::ThreadTrack::Analyze; +use strict; +use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD); +use Carp; + +=head1 NAME + +Mail::ThreadTrack::Analyze - analyze mail thread relation + +=head1 SYNOPSIS + + my $ticket = $pkg->new($args); + if (defined $ticket) { + $ticket->analyze($msg); + $ticket->rewrite_header($msg); + } + +=head1 DESCRIPTION + +=head1 METHODS + +=cut + + +=head2 C<analyze($mesg)> + +C<$mesg> is Mail::Message object. + +1) assign a new ticket or extract the existing ticket-id from the subject. + +2) update ticket status if needed. + +=cut + + +sub analyze +{ + my ($self, $msg) = @_; + $self->_assign($msg); + $self->update_ticket_status($msg); + $self->update_db($msg); +} + + +=head2 assign($msg) + +=cut + + +sub _is_reply +{ + my ($subject) = @_; + + use Mail::Message::Language::Japanese::Subject; + return Mail::Message::Language::Japanese::Subject::is_reply($subject); +} + + +# Descriptions: assign a new ticket or +# extract the existing ticket-id from the subject +# Arguments: $self $curproc $args +# Side Effects: a new ticket_id may be assigned +# article header is rewritten +# Return Value: none +sub _assign +{ + my ($self, $msg) = @_; + my $config = $self->{ _config }; + my $header = $msg->rfc822_message_header(); + my $subject = $header->get('subject'); + my $pcb = $self->{ _pcb }; + my $is_reply = _is_reply($subject); + + # 1. try to extract $ticket_id from subject: field + my $ticket_id = $self->_extract_ticket_id_in_subject($header, $config); + unless ($ticket_id) { + # 1.1 hmm, we tail to but we try to speculate ticket_id + # from other header information. + $ticket_id = $self->_speculate_ticket_id($msg); + if ($ticket_id) { + $is_reply = 1; + $self->{ _ticket_id } = $ticket_id; + Log("speculated id=$ticket_id"); + } + else { + Log("(debug) fail to spelucate ticket_id"); + } + } + + # 2. check "X-Ticket-Pragma:" field, + # we ignore this mail if the pragma is specified as "ignore". + if (defined $header->get('x-ticket-pragma')) { + my $pragma = $header->get('x-ticket-pragma') || ''; + if ($pragma =~ /ignore/i) { + $self->{ _pragma } = 'ignore'; + $self->_append_ticket_status_info("ignored"); + return undef; + } + } + + # if the header carries "Subject: Re: ..." with ticket-id, + # we do not rewrite the subject but save the extracted $ticket_id. + if ($is_reply && $ticket_id) { + Log("reply message with ticket_id=$ticket_id"); + $self->{ _ticket_id } = $ticket_id; + $self->{ _status } = 'analyzed'; + $self->_append_ticket_status_info('analyzed'); + } + elsif ($ticket_id) { + Log("usual message with ticket_id=$ticket_id"); + $self->{ _ticket_id } = $ticket_id; + $self->_append_ticket_status_info("found"); + } + else { + Log("message with no ticket_id"); + + # assign a new ticket number for a new message + my $id = $self->increment_id(); + + # O.K. rewrite Subject: of the article to distribute + unless ($self->error) { + $pcb->{'article'}->{'id'} = $id; # save $id info in PCB + + my $header = $msg->rfc822_message_header(); + $self->_get_ticket_id($header, $config, $id); + $self->_rewrite_header($header, $config, $id); + $self->_append_ticket_status_info("newly assigned"); + } + else { + Log( $self->error ); + } + } +} + + +# For example, consider a posting to both elena ML and rudo (DM) from kenken. +# +# From: kenken +# To: elena-ml +# Cc: rudo +# +# The reply to this DM (direct message) from rudo is +# +# From: rudo +# To: elena-ml +# +# This reply message has no ticket_id since the message from kenken to +# rudo comes directly from kenken not through fml driver. +# In this case, we try to speculdate the reply relation and the ticket_id +# of this thread by using _speculate_ticket_id(). +# +sub _speculate_ticket_id +{ + my ($self, $msg) = @_; + my $header = $msg->rfc822_message_header(); + my $midlist = _extract_message_id_references( $header ); + my $result = ''; + + for (@$midlist) { Log("(debug) mid=$_");} + + if (defined $midlist) { + $self->db_open(); + + # prepare hash table tied to db_dir/*db's + my $rh = $self->{ _hash_table }; + + for my $mid (@$midlist) { + $result = $rh->{ _message_id }->{ $mid }; + last if $result; + } + + $self->db_close(); + } + + Log("(debug) not speculated") unless $result; + $result; +} + + +sub _append_ticket_status_info +{ + my ($self, $s) = @_; + $self->{ _status_info } .= $self->{ _status_info } ? " -> ".$s : $s; +} + + +=head2 update_ticket_status($msg) + +=cut + + +sub update_ticket_status +{ + my ($self, $msg) = @_; + + return if $self->{ _pragma } eq 'ignore'; + + # entries to check + my $header = $msg->rfc822_message_header(); + my $subject = $header->get('subject'); + my $pragma = $header->get('x-ticket-pragma') || ''; + + my $content = ''; + my $message = $msg->get_first_plaintext_message(); + if (ref($message) eq 'Mail::Message') { + $content = $message->data_in_body_part(); + } + else { + croak("invalid object"); + } + + if ($content =~ /^\s*close/ || + $subject =~ /^\s*close/ || + $pragma =~ /close/ ) { + $self->{ _status } = "closed"; + $self->_append_ticket_status_info("closed"); + Log("ticket is closed"); + } + else { + Log("ticket status not changed"); + } +} + + +# Descriptions: create regexp for a subject tag, for example +# "[%s %05d]" => "\[\S+ \d+\]" +# Arguments: a subject tag string +# XXX non OO type function +# Side Effects: none +# Return Value: a regexp for the given tag +sub _regexp_compile +{ + my ($s) = @_; + + $s = quotemeta( $s ); + $s =~ s@\\\%@\%@g; + $s =~ s@\%s@\\S+@g; + $s =~ s@\%d@\\d+@g; + $s =~ s@\%0\d+d@\\d+@g; + $s =~ s@\%\d+d@\\d+@g; + $s =~ s@\%\-\d+d@\\d+@g; + + # quote for regexp substitute: [ something ] -> \[ something \] + # $s =~ s/^(.)/quotemeta($1)/e; + # $s =~ s/(.)$/quotemeta($1)/e; + + return $s; +} + + +sub _extract_message_id_references +{ + my ($header) = @_; + my $buf = + $header->get('in-reply-to') ."\n". $header->get('references'); + + use Mail::Address; + my @addrs = Mail::Address->parse($buf); + + my @r = (); + my %uniq = (); + foreach my $addr (@addrs) { + my $a = $addr->address; + unless ($uniq{ $a }) { + push(@r, $addr->address); + $uniq{ $a } = 1; + } + } + + \@r; +} + + +sub _extract_ticket_id_in_subject +{ + my ($self, $header, $config) = @_; + my $tag = $config->{ ticket_subject_tag }; + my $subject = $header->get('subject'); + my $regexp = _regexp_compile($tag); + + # Subject: ... [ticket_id] + if (($config->{ ticket_subject_tag_location } eq 'appended') && + ($subject =~ /($regexp)\s*$/)) { + my $id = $1; + $id =~ s/^(\[|\(|\{)//; + $id =~ s/(\]|\)|\})$//; + return $id; + } + # XXX incomplete, we check subject after cutting off "Re:" et. al. + # Subject: [ticket_id] ... + # Subject: Re: [ticket_id] ... + elsif (($config->{ ticket_subject_tag_location } eq 'appended') && + ($subject =~ /^\s*($regexp)/)) { + my $id = $1; + $id =~ s/^(\[|\(|\{)//; + $id =~ s/(\]|\)|\})$//; + return $id; + } + else { + Log("no ticket id /$regexp/ in subject"); + return 0; + } +} + + +sub _get_ticket_id +{ + my ($self, $header, $config, $id) = @_; + my $subject_tag = $config->{ ticket_subject_tag }; + my $id_syntax = $config->{ ticket_id_syntax }; + + # ticket_id in subject + my $ticket_id = sprintf($subject_tag, $id); + $self->{ _ticket_subject_tag } = $ticket_id; + + $ticket_id = sprintf($id_syntax, $id); + $self->{ _ticket_id } = $ticket_id; + + return $ticket_id; +} + + +sub _rewrite_header +{ + my ($self, $header, $config, $id) = @_; + + # append the ticket tag to the subject + my $subject = $header->get('subject') || ''; + $header->replace('Subject', + $subject." " . $self->{ _ticket_subject_tag }); +} + + +# clean up given C<address>. +# It parse it by C<Mail::Address::parse()> and nuke < and >. +sub _address_clean_up +{ + my ($self, $addr) = @_; + + use Mail::Address; + my @addrlist = Mail::Address->parse($addr); + + # only the first element in the @addrlist array is effective. + $addr = $addrlist[0]->address; + $addr =~ s/^\s*<//; + $addr =~ s/>\s*$//; + + # return the result. + return $addr; +} + + +=head2 update_db($msg) + +=cut + + +sub update_db +{ + my ($self, $msg) = @_; + my $config = $self->{ _config }; + my $ml_name = $config->{ ml_name }; + + return if $self->{ _pragma } eq 'ignore'; + + $self->db_open(); + + # save $ticke_id et.al. in db_dir/$ml_name + $self->_update_db($msg); + + # save cross reference pointers among $ml_name + $self->_update_index_db(); + + $self->db_close(); +} + + +sub _update_db +{ + my ($self, $msg) = @_; + my $config = $self->{ _config }; + my $pcb = $self->{ _pcb }; + my $article_id = $pcb->{'article'}->{'id'}; + my $ticket_id = $self->{ _ticket_id }; + + # 0. logging + Log("article_id=$article_id ticket_id=$ticket_id"); + + # prepare hash table tied to db_dir/*db's + my $rh = $self->{ _hash_table }; + + # 1. + $rh->{ _ticket_id }->{ $article_id } = $ticket_id; + $rh->{ _date }->{ $article_id } = time; + $rh->{ _articles }->{ $ticket_id } .= $article_id . " "; + + # 2. record the sender information + my $header = $msg->rfc822_message_header; + $rh->{ _sender }->{ $article_id } = $header->get('from'); + + # 3. update status information + if (defined $self->{ _status }) { + $self->_set_status($ticket_id, $self->{ _status }); + } + else { + # set the default status value for the first time. + unless (defined $rh->{ _status }->{ $ticket_id }) { + $self->_set_status($ticket_id, 'open'); + } + } + + # 4. save optional/additional information + # message_id hash is { message_id => ticket_id }; + my $mid = $header->get('message-id'); + $mid = $self->_address_clean_up($mid); + $rh->{ _message_id }->{ $mid } = $ticket_id; + + # 5. history + my $buf = ''; + my (@aid) = split(/\s+/, $rh->{ _articles }->{ $ticket_id }); + my $sender = $rh->{ _sender }->{ $aid[0] }; + my $when = $rh->{ _date }->{ $aid[0] }; + + # clean up + $sender =~ s/[\s\n]*$//; + $when =~ s/[\s\n]*$//; + + use Mail::Message::Date; + $when = Mail::Message::Date->new($when)->mail_header_style(); + + $buf .= "\t\n"; + $buf .= "\tthis ticket/thread is opended at article $aid[0]\n"; + $buf .= "\tby $sender\n"; + $buf .= "\ton $when\n"; + $buf .= "\tarticle references: @aid\n"; + $self->{ _status_history } = $buf; +} + + +# register myself to index_db for further reference among mailing lists +sub _update_index_db +{ + my ($self) = @_; + my $config = $self->{ _config }; + my $ticket_id = $self->{ _ticket_id }; + my $rh = $self->{ _hash_table }; + my $ml_name = $config->{ ml_name }; + + my $ref = $rh->{ _index }->{ $ticket_id } || ''; + if ($ref !~ /^$ml_name|\s$ml_name\s|$ml_name$/) { + $rh->{ _index }->{ $ticket_id } .= $ml_name." "; + } +} + + +=head2 C<set_status($args)> + +set $status for $ticket_id. It rewrites DB (file). +C<$args>, HASH reference, must have two keys. + + $args = { + ticket_id => $ticket_id, + status => $status, + } + +C<set_status()> calls db_open() an db_close() automatically within it. + +=cut + + +# Descriptions: +# Arguments: $self $curproc $args +# Side Effects: +# Return Value: none +sub set_status +{ + my ($self, $args) = @_; + my $ticket_id = $args->{ ticket_id }; + my $status = $args->{ status }; + + Log("ticket.set_status($ticket_id, $status)"); + + $self->db_open(); + $self->_set_status($ticket_id, $status); + $self->db_close(); +} + + +sub _set_status +{ + my ($self, $ticket_id, $value) = @_; + $self->{ _hash_table }->{ _status }->{ $ticket_id } = $value; +} + + +sub Log +{ + print STDERR "Log> @_\n"; +} + + +=head1 AUTHOR + +Ken'ichi Fukamachi + +=head1 COPYRIGHT + +Copyright (C) 2001 Ken'ichi Fukamachi + +All rights reserved. This program is free software; you can +redistribute it and/or modify it under the same terms as Perl itself. + +=head1 HISTORY + +Mail::ThreadTrack::Analyze appeared in fml5 mailing list driver package. +See C<http://www.fml.org/> for more details. + +=cut + + +1; |