diff options
| -rwxr-xr-x | fml/lib/Mail/ThreadTrack.pm | 362 | ||||
| -rw-r--r-- | fml/lib/Mail/ThreadTrack/Analyze.pm | 530 | ||||
| -rw-r--r-- | fml/lib/Mail/ThreadTrack/DB.pm | 122 | ||||
| -rw-r--r-- | fml/lib/Mail/ThreadTrack/ErrorStatus.pm | 111 | ||||
| -rw-r--r-- | fml/lib/Mail/ThreadTrack/HeaderRewrite.pm | 72 | ||||
| -rw-r--r-- | fml/lib/Mail/ThreadTrack/Print.pm | 288 | ||||
| -rw-r--r-- | fml/lib/Mail/ThreadTrack/Print/CGI.pm | 192 | ||||
| -rw-r--r-- | fml/lib/Mail/ThreadTrack/Print/Text.pm | 0 |
8 files changed, 1677 insertions, 0 deletions
diff --git a/fml/lib/Mail/ThreadTrack.pm b/fml/lib/Mail/ThreadTrack.pm new file mode 100755 index 00000000..0f39fba5 --- /dev/null +++ b/fml/lib/Mail/ThreadTrack.pm @@ -0,0 +1,362 @@ +#-*- 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; +use strict; +use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD); +use Carp; +use Mail::ThreadTrack::ErrorStatus qw(error_set error error_clear); + +use Mail::ThreadTrack::Analyze; +use Mail::ThreadTrack::HeaderRewrite; +use Mail::ThreadTrack::DB; + +@ISA = qw(Mail::ThreadTrack::Analyze + Mail::ThreadTrack::DB + Mail::ThreadTrack::HeaderRewrite + ); + + +=head1 NAME + +Mail::ThreadTrack - analyze mail threading + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 C<new($args)> + + $args = { + db_base_dir => "/var/spool/ml/\@db\@/ticket", + fd => \*STDOUT, + config => { + ml_name => 'elena', + }, + }; + +C<db_base_dir> and C<ml_name> in C<config> are mandatory. + +=cut + + +# Descriptions: constructor +# Arguments: $self +# Side Effects: none +# Return Value: object +sub new +{ + my ($self, $args) = @_; + my ($type) = ref($self) || $self; + my $me = {}; + + # config + my $config = $me->{ _config } = {}; + + for my $key (qw(ml_name spool_dir)) { + $config->{ $key } = $args->{ config }->{ $key }; + } + + my $ml_name = $config->{ ml_name }; + if (defined $ml_name) { + $config->{ _ml_name } = $ml_name; + } + else { + croak("specify \$ml_name\n"); + } + + unless (defined $args->{ ticket_id_syntax }) { + $config->{ ticket_id_syntax } = "$ml_name/\%d"; + } + + unless (defined $args->{ ticket_subject_tag }) { + my $id_syntax = $config->{ ticket_id_syntax }; + $config->{ ticket_subject_tag } = "[$id_syntax]"; + } + + # database directory used to store thread information et. al. + use File::Spec; + my $base_dir = $args->{ db_base_dir }; + $me->{ _db_base_dir } = $base_dir; + $me->{ _db_dir } = File::Spec->catfile($base_dir, $ml_name); + $me->{ _fd } = $args->{ fd } || \*STDOUT; + $me->{ _pcb } = {}; + + # initialize directory + _init_ticket_db_dir($me); + + return bless $me, $type; +} + + +sub DESTROY {} + + +# Descriptions: "mkdir -p" or "mkdirhier" +# Arguments: directory [file_mode] +# Side Effects: set $ErrorString +# Return Value: succeeded to create directory or not +sub _mkdirhier +{ + my ($dir, $mode) = @_; + $mode = defined $mode ? $mode : 0700; + + error_clear(); + + # XXX $mode (e.g. 0755) should be a numeric not a string + eval q{ + use File::Path; + mkpath($dir, 0, $mode); + }; + + return ($@ ? undef : 1); +} + + +# Descriptions: set up directory which is taken from +# $self->{ _db_dir } +# Arguments: $self $curproc $args +# Side Effects: create a "_db_dir" directory if needed +# Return Value: 1 (success) or undef (fail) +sub _init_ticket_db_dir +{ + my ($self, $args) = @_; + + if (defined $self->{ _db_dir }) { + my $db_dir = $self->{ _db_dir }; + unless (-d $db_dir) { + _mkdirhier($db_dir) || do { + croak("cannot make \$db_dir=$db_dir\n"); + }; + } + } + else { + croak("no \$db_dir\n"); + } + + return 1; +} + + +=head2 C<increment_id(file)> + +increment ticket number which is taken up from C<file> +and save its new number to C<file>. + +=cut + + +# Descriptions: increment ticket number $id holded in $seq_file +# Arguments: $self $seq_file +# Side Effects: increment id holded in $seq_file +# Return Value: number +sub increment_id +{ + my ($self, $seq_file) = @_; + my $seq = 0; + + $self->db_open(); + + # prepare hash table tied to db_dir/*db's + my $rh = $self->{ _hash_table }; + + if (defined $rh->{ _info }->{ sequence }) { + $rh->{ _info }->{ sequence }++; + return $rh->{ _info }->{ sequence }; + } + else { + $seq = $rh->{ _info }->{ sequence } = 1; + } + + $self->db_close(); + + return $seq; +} + + +=head2 list_up_ticket_id() + +return @ticket_id ARRAY + +=cut + +# return @ticket_id ARRAY +sub list_up_ticket_id +{ + my ($self) = @_; + my ($tid, $status, @ticket_id); + + # self->{ _hash_table } is tied to DB's. + $self->db_open(); + + my $rh_status = $self->{ _hash_table }->{ _status }; + my $mode = 'default'; + + TICEKT_LIST: + while (($tid, $status) = each %$rh_status) { + if ($mode eq 'default') { + next TICEKT_LIST if $status =~ /close/o; + } + + push(@ticket_id, $tid); + } + + $self->db_close(); + + \@ticket_id; +} + + +=head2 sort($ticket_id_list) + +=cut + + +sub sort +{ + my ($self, $ticket_id_list) = @_; + + # get age HASH TABLE + my ($age, $cost) = $self->_calculate_age($ticket_id_list); + $self->{ _age } = $age; + $self->{ _cost } = $cost; + + $self->_sort_ticket_id($ticket_id_list, $cost); +} + + +sub _sort_ticket_id +{ + my ($self, $ticket_id_list, $cost) = @_; + + @$ticket_id_list = sort { + $cost->{$b} cmp $cost->{$a}; + } @$ticket_id_list; +} + + +sub _calculate_age +{ + my ($self, $ticket_id_list) = @_; + my (%age, %cost) = (); + my $now = time; # save the current UTC for convenience + my $rh = $self->{ _hash_table } || {}; + my $day = 24*3600; + + # $age hash referehence = { $ticket_id => $age }; + my (@aid, $last, $age, $date, $status, $tid) = (); + for $tid (sort @$ticket_id_list) { + # $last: get the latest one of article_id's + (@aid) = split(/\s+/, $rh->{ _articles }->{ $tid }); + $last = $aid[ $#aid ] || 0; + + # how long this ticket is not concerned ? + $age = sprintf("%2.1f%s", ($now - $rh->{ _date }->{ $last })/$day); + $age{ $tid } = $age; + + # evaluate cost hash table which is { $ticket_id => $cost } + $cost{ $tid } = $rh->{ _status }->{ $tid }.'-'. $age; + } + + return (\%age, \%cost); +} + + +=head2 set_mode($mode) + +specify output format by $mode string. +"text" and "html" are available. +"text" by default. + +=head2 get_mode() + +get output format. + +=cut + + +# Descriptions: set output format +# Arguments: $self $string +# Side Effects: none +# Return Value: string +sub set_mode +{ + my ($self, $mode) = @_; + $self->{ _mode } = $mode || 'text'; +} + + +# Descriptions: set output format +# Arguments: $self +# Side Effects: none +# Return Value: string +sub get_mode +{ + my ($self) = @_; + return(defined $self->{ _mode } ? $self->{ _mode } : undef); +} + + +# +# DEBUG +# +if ($0 eq __FILE__) { + eval q{ + my $args = { + db_base_dir => "/var/spool/ml/\@db\@/ticket", + fd => \*STDOUT, + config => { + ml_name => 'elena', + spool_dir => '/var/spool/ml/elena/spool', + }, + }; + + for my $f (@ARGV) { + use Mail::Message; + my $fh = new FileHandle $f; + my $msg = Mail::Message->parse( { fd => $fh } ); + + my $ticket = new Mail::ThreadTrack $args; + $ticket->analyze($msg); + + use Mail::ThreadTrack::Print; + push(@ISA, 'Mail::ThreadTrack::Print'); + $ticket->show_summary(); + + use Data::Dumper; + print Dumper( $ticket ); + } + + }; + croak($@) if $@; +} + + +=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 appeared in fml5 mailing list driver package. +See C<http://www.fml.org/> for more details. + +=cut + + +1; 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; diff --git a/fml/lib/Mail/ThreadTrack/DB.pm b/fml/lib/Mail/ThreadTrack/DB.pm new file mode 100644 index 00000000..87d4ba02 --- /dev/null +++ b/fml/lib/Mail/ThreadTrack/DB.pm @@ -0,0 +1,122 @@ +#-*- 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::DB; +use strict; +use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD); +use Carp; + +=head1 NAME + +Mail::ThreadTrack::DB - what is this + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 METHODS + +=cut + +=head2 C<db_open()> + +open DB. +It uses tie() to bind a hash to a DB file. +Our minimal_states uses several DB files for +C<%ticket_id>, +C<%date>, +C<%status>, +C<%sender>, +C<%articles>, +C<%message_id> +and +C<%index>. + +=head2 C<db_close()> + +untie() corresponding hashes opened by C<db_open()>. + +=cut + + +my @kind_of_databases = qw(ticket_id + info + date + status + sender + articles + message_id + index); + + +sub db_open +{ + my ($self) = @_; + my $db_type = $self->{ config }->{ ticket_db_type } || 'AnyDBM_File'; + my $db_dir = $self->{ _db_dir }; + + my $index_file = $self->{ _index_db }; + + eval qq{ use $db_type; use Fcntl;}; + unless ($@) { + for my $db (@kind_of_databases) { + my $file = "$db_dir/${db}"; + my $str = qq{ + my \%$db = (); + tie \%$db, \$db_type, \$file, O_RDWR|O_CREAT, 0644; + \$self->{ _hash_table }->{ _$db } = \\\%$db; + }; + eval $str; + croak($@) if $@; + } + } + else { + croak("cannot use $db_type"); + } + + 1; +} + + +sub db_close +{ + my ($self) = @_; + + for my $db (@kind_of_databases) { + my $str = qq{ + my \$${db} = \$self->{ _hash_table }->{ _$db }; + untie \%\$${db}; + }; + eval $str; + croak($@) if $@; + } +} + + + +=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::DB appeared in fml5 mailing list driver package. +See C<http://www.fml.org/> for more details. + +=cut + + +1; diff --git a/fml/lib/Mail/ThreadTrack/ErrorStatus.pm b/fml/lib/Mail/ThreadTrack/ErrorStatus.pm new file mode 100644 index 00000000..670f0a76 --- /dev/null +++ b/fml/lib/Mail/ThreadTrack/ErrorStatus.pm @@ -0,0 +1,111 @@ +#-*- 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: Mail::ThreadTrack::ErrorStatus.pm,v 1.1 2001/04/08 13:25:37 fukachan Exp $ +# + +package Mail::ThreadTrack::ErrorStatus; + +use strict; +use vars qw(@ISA @EXPORT @EXPORT_OK); +use Carp; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT_OK = qw(errstr error error_set error_clear); + +=head1 NAME + +Mail::ThreadTrack::ErrorStatus - error handling component + +=head1 SYNOPSIS + +Use this module in your C<Something> class module like this: + + package Something; + use Mail::ThreadTrack::ErrorStatus qw(errstr error error_set error_clear); + + sub xxx + { + if something errors ... + $self->error_set( why this error occurs ... ); + } + +You use C<Something> module like this. + + use Something; + $obj = new Something; + $obj->xxx(); + unless ($obj->error) { $obj->do_somting( ...); }; + +=head1 DESCRIPTION + +simple utility functions to manipulate error messages. + +=head1 METHODS + +=head2 C<error_set($message)> + +save $message as an error message. + +=head2 C<error()> + +return $message which is saved by C<error_set($msg)>. + +=cut + + +sub error_set +{ + my ($self, $mesg) = @_; + $self->{'_error_reason'} = $mesg; +} + + +sub error +{ + my ($self, $args) = @_; + return $self->{'_error_reason'}; +} + + +sub errstr +{ + my ($self, $args) = @_; + return $self->{'_error_reason'}; +} + + +sub error_clear +{ + my ($self, $args) = @_; + my $msg = $self->{'_error_reason'}; + undef $self->{'_error_reason'} if defined $self->{'_error_reason'}; + undef $self->{'_error_action'} if defined $self->{'_error_action'}; + return $msg; +} + + +=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::ErrorStatus appeared in fml5 mailing list driver package. +See C<http://www.fml.org/> for more details. + +=cut + + +1; diff --git a/fml/lib/Mail/ThreadTrack/HeaderRewrite.pm b/fml/lib/Mail/ThreadTrack/HeaderRewrite.pm new file mode 100644 index 00000000..ee6f860a --- /dev/null +++ b/fml/lib/Mail/ThreadTrack/HeaderRewrite.pm @@ -0,0 +1,72 @@ +#-*- 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.2 2001/10/27 04:27:18 fukachan Exp $ +# + +package Mail::ThreadTrack::HeaderRewrite; +use strict; +use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD); +use Carp; + +=head1 NAME + +Mail::ThreadTrack::HeaderRewrite - what is this + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 METHODS + +=cut + +=head2 C<rewrite_header($msg)> + +C<$msg> is Mail::Message object. + +=cut + + +sub rewrite_header +{ + my ($self, $msg) = @_; + my $header = $msg->rfc822_message_header; + + if (defined $self->{ _status_info }) { + $header->add('X-Ticket-Status', $self->{ _status_info }); + } + + if (defined $self->{ _ticket_id }) { + $header->add('X-Ticket-ID', $self->{ _ticket_id }); + } + + if (defined $self->{ _status_history }) { + $header->add('X-Ticket-History', $self->{ _status_history }); + } +} + + +=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::HeaderRewrite appeared in fml5 mailing list driver package. +See C<http://www.fml.org/> for more details. + +=cut + + +1; diff --git a/fml/lib/Mail/ThreadTrack/Print.pm b/fml/lib/Mail/ThreadTrack/Print.pm new file mode 100644 index 00000000..d9db0ae5 --- /dev/null +++ b/fml/lib/Mail/ThreadTrack/Print.pm @@ -0,0 +1,288 @@ +#-*- 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::Print; +use strict; +use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD); +use Carp; + +my $is_show_cost_indicate = 0; + +=head1 NAME + +Mail::ThreadTrack::Print - print out thread relation + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 C<show_summary(>) + +top level entrance for routines to show the ticket summary. + +See L<simple_print()> for more detail. +Either of +C<simple_print()> +or +C<_summary_print()> +is used for purposes. + +Each row that C<show_summary()> returns has a set of +C<date>, C<age>, C<status>, C<ticket-id> and +C<articles>, which is a list of articles with the ticket-id. + +=head2 C<simple_print()> + +show entries by the ticket_id order. For example, + + date age status ticket id articles + ------------------------------------------------------------ + 2001/02/07 3.6 going elena_#00000450 807 808 809 + 2001/02/07 3.1 open elena_#00000451 810 + 2001/02/07 3.0 open elena_#00000452 812 + 2001/02/07 3.0 open elena_#00000453 813 + 2001/02/07 3.0 going elena_#00000454 814 815 + 2001/02/10 0.1 open elena_#00000456 821 + +=head2 C<_summary_print()> + +show entries in the C<cost> larger order. +The cost is evaluated by $status and $age. +The cost is larger as $age is larger. +It is also larger if $status is C<open>. + +=cut + + +sub show_summary +{ + my ($self) = @_; + my ($tid, $status, $ticket_id); + my $mode = $self->get_mode || 'text'; + + # rh: ticket id list, which is ARRAY REFERENCE tied to db_dir/*db's + $ticket_id = $self->list_up_ticket_id(); + + # self->{ _hash_table } is tied to DB's. + $self->db_open(); + + if (@$ticket_id) { + # sort the ticket output order it out by cost + # and print the ticket summary in that order. + $self->sort($ticket_id); + + if ($mode eq 'html') { + print "<TABLE BORDER=4>\n" if $mode eq 'html'; + $self->_print_ticket_summary($ticket_id); + print "</TABLE>\n" if $mode eq 'html'; + } + else { + $self->_print_ticket_summary($ticket_id); + + # show short summary for each article + $self->_print_article_summary($ticket_id); + } + } + + # self->{ _hash_table } is untied from DB's. + $self->db_close(); +} + + + +sub _print_ticket_summary +{ + my ($self, $ticket_id) = @_; + my $mode = $self->get_mode || 'text'; + my $rh_age = $self->{ _age } || {}; + my $fd = $self->{ _fd } || \*STDOUT; + my $rh = $self->{ _hash_table }; + my $format = "%10s %5s %6s %-20s %s\n"; + + if ($mode eq 'text') { + printf($fd $format, 'date', 'age', 'status', 'ticket id', 'articles'); + print $fd "-" x60; + print $fd "\n"; + } + else { + print "<TD>action\n"; + print "<TD>date\n"."<TD>age\n"."<TD>status\n"."<TD>ticket id\n"; + print "<TD>article summary\n"; + } + + my ($tid, @article_id, $article_id, $date, $age, $status) = (); + my $dh = new Mail::Message::Date; + for $tid (@$ticket_id) { + # get the first $article_id from the article_id list + (@article_id) = split(/\s+/, $rh->{ _articles }->{ $tid }); + $article_id = $article_id[0]; + + # determine $date for the $article_id + # $age and $status for $ticket_id + $date = $dh->YYYYxMMxDD( $rh->{ _date }->{ $article_id } , '/'); + $age = $rh_age->{ $tid }; + $status = $rh->{ _status }->{ $tid }; + + if ($mode eq 'html') { + $self->_show_ticket_by_html_table( { + format => $format, + date => $date, + age => $age, + status => $status, + tid => $tid, + articles => $rh->{ _articles }->{ $tid }, + }); + } + else { + printf($fd $format, + $date, $age, $status, $tid, $rh->{ _articles }->{ $tid }); + } + } +} + + +sub _cost_to_indicator +{ + my ($cost) = @_; + my $how_bad = 0; + + if ($cost =~ /(\w+)\-(\d+)/) { + $how_bad += $2; + $how_bad += 2 if $1 =~ /open/; + $how_bad = "!" x ($how_bad > 6 ? 6 : $how_bad); + } +} + + +sub _print_article_summary +{ + my ($self, $ticket_id) = @_; + my $config = $self->{ _config }; + my $age = $self->{ _age } || {}; + my $cost = $self->{ _cost } || {}; + my $fd = $self->{ _fd } || \*STDOUT; + my $rh = $self->{ _hash_table }; + + if (defined $config->{ spool_dir }) { + my ($aid, @aid); + + if ($is_show_cost_indicate) { + print $fd "\n\"!\" mark: stalled? please check and reply it.\n"; + } + + my $spool_dir = $config->{ spool_dir }; + for my $tid (@$ticket_id) { + if ($is_show_cost_indicate) { + my $how_bad = _cost_to_indicator( $cost->{ $tid } ); + printf $fd "\n%6s %-10s %s\n", $how_bad, $tid; + } + else { + printf $fd "\n>Thread-Id: %-10s %s\n", $tid; + } + + (@aid) = split(/\s+/, $rh->{ _articles }->{ $tid }); + $aid = $aid[0]; + my $file = File::Spec->catfile($spool_dir, $aid); + print $fd $self->__article_summary($file); + } + } +} + + +sub __article_summary +{ + my ($self, $file) = @_; + my (@header) = (); + my $buf = ''; + my $line = 3; + my $mode = $self->get_mode || 'text'; + my $padding = $mode eq 'text' ? ' ' : ''; + + use FileHandle; + my $fh = new FileHandle $file; + + if (defined $fh) { + LINE: + while (<$fh>) { + # nuke useless lines + next LINE if /^\>/; + next LINE if /^\-/; + + if (1 ../^$/) { + push(@header, $_); + } + else { + next LINE if /^\s*$/; + + # ignore mail header like patterns + next LINE if /^X-[-A-Za-z0-9]+:/i; + next LINE if /^Return-[-A-Za-z0-9]+:/i; + next LINE if /^Mime-[-A-Za-z0-9]+:/i; + next LINE if /^Content-[-A-Za-z0-9]+:/i; + next LINE if /^(To|From|Subject|Reply-To|Received):/i; + next LINE if /^(Message-ID|Date):/i; + + # pick up effetive the first $line lines + if ($line-- > 0) { + $buf .= $padding. $_; + } + else { + last LINE; + } + } + } + close($fh); + } + + use Mail::Header; + my $h = new Mail::Header \@header; + my $header_info = $self->_header_summary({ + header => $h, + padding => $padding, + }); + + return $header_info . $buf; +} + + +sub _delete_subject_tag_like_string +{ + my ($str) = @_; + $str =~ s/\W[-\w]+.\s*\d+\W//g; + $str =~ s/\s+/ /g; + $str =~ s/^\s*//g; + $str; +} + + +sub _header_summary +{ + my ($self, $args) = @_; + my $from = $args->{ header }->get('from'); + my $subject = $args->{ header }->get('subject'); + my $padding = $args->{ padding }; + + use FML::MIME qw(decode_mime_string); + $subject = decode_mime_string($subject, { charset => 'euc-japan' }); + $subject =~ s/\n/ /g; + $subject = _delete_subject_tag_like_string($subject); + + $from = decode_mime_string($from, { charset => 'euc-japan' }); + $from =~ s/\n/ /g; + + my $br = $self->get_mode eq 'html' ? '<BR>' : ''; + return + $padding. " From: ". $from ."$br\n". + $padding. "Subject: ". $subject ."$br\n"; +} + + +1; diff --git a/fml/lib/Mail/ThreadTrack/Print/CGI.pm b/fml/lib/Mail/ThreadTrack/Print/CGI.pm new file mode 100644 index 00000000..6fe0e844 --- /dev/null +++ b/fml/lib/Mail/ThreadTrack/Print/CGI.pm @@ -0,0 +1,192 @@ +sub STR2EUC +{ + my ($str) = @_; + + use Jcode; + &Jcode::convert(\$str, 'euc'); + return $str; +} + + +sub show_articles_for_ticket +{ + my ($self, $ticket_id) = @_; + my $mode = $self->get_mode || 'text'; + my $config = $self->{ _config }; + my $spool_dir = $config->{ spool_dir }; + + $self->db_open(); + + my $articles = $self->{ _hash_table }->{ _articles }->{ $ticket_id }; + + print "<B>"; + print "show contents related with ticket_id=$ticket_id\n"; + print "</B>"; + print "<HR>"; + print "<PRE>\n"; + + if (defined($articles) && defined($spool_dir) && -d $spool_dir) { + use FileHandle; + + my $s = ''; + for (split(/\s+/, $articles)) { + my $file = File::Spec->catfile($spool_dir, $_); + my $fh = new FileHandle $file; + while (defined($_ = $fh->getline())) { + next if 1 .. /^$/; + + $s = STR2EUC($_); + $s =~ s/&/&/g; + $s =~ s/</</g; + $s =~ s/>/>/g; + $s =~ s/\"/"/g; + print $s; + } + $fh->close; + } + } + + print "</PRE>"; + + $self->db_close(); +} + + +sub cgi_top_menu +{ + my ($self) = @_; + my $config = $self->{ _config }; + my $action = 'fmlticket.cgi'; + my $target = $config->{ ticket_cgi_target_window } || 'TicketCGIWindow'; + + use DirHandle; + my $dh = new DirHandle $config->{ ml_home_prefix }; + my @dirlist; + my $prefix = $config->{ ml_home_prefix }; + while ($_ = $dh->read()) { + next if /^\./; + next if /^\@/; + push(@dirlist, $_) if -f "$prefix/$_/config.cf"; + } + $dh->close; + + if ($self->get_mode eq 'html') { + require 'ctime.pl'; + my $time = ctime(time); + my $ml_name = $config->{ ml_name }; + print "[$time] the brief summary for \"$ml_name\" ML<BR>"; + } + + use CGI qw/:standard/; + print start_form(-action=>$action, -target=>$target); + print "mailing list: ", + popup_menu(-name => 'ml_name', -values => \@dirlist), + submit(-name => 'go'), + end_form; +} + + + +# This shows summary on C<$ticket_id> in HTML language. +# It is used in C<FML::CGI::TicketSystem>. +sub _show_ticket_by_html_table +{ + my ($self, $optargs) = @_; + my $config = $self->{ _config }; + my $ml_name = $config->{ ml_name }; + my $spool_dir = $config->{ spool_dir }; + my $action = 'fmlticket.cgi'; + my $target = $config->{ ticket_cgi_target_window } || 'TicketCGIWindow'; + + # printf($fd $format, + # $date, $age, $status, $tid, $rh->{ _articles }->{ $tid }); + my $format = $optargs->{ format }; + my $date = $optargs->{ date }; + my $age = $optargs->{ age }; + my $status = $optargs->{ status }; + my $tid = $optargs->{ tid }; + my $articles = $optargs->{ articles }; + my $aid = (split(/\s+/, $articles))[0]; + + # do nothing if the $ticket_id is unknown. + return unless $tid; + + # <FORM ACTION=> ..> + my $xtid = CGI::escape($tid); + $action = "${action}?ml_name=${ml_name}"; + $action .= "&ticket_id=$xtid&article_id=$aid"; + + print "<TR>\n"; + print "<TD>"; + print "<A HREF=\"$action&action=close\" TARGET=\"$target.close\">"; + print "[close]</A>\n"; + print "<BR>\n"; + print "<A HREF=\"$action&action=show\" TARGET=\"$target.show\">"; + print "[see articles]</A>\n"; + print "<TD>$date\n"; + print "<TD>$age\n"; + print "<TD>$status\n"; + print "<TD>$tid\n"; + print "<TD>"; + + $aid = (split(/\s+/, $articles))[0]; + my $buf = $self->_article_summary(File::Spec->catfile($spool_dir, $aid)); + print STR2EUC($buf); +} + + +=head2 C<run_cgi()> + +execute CGI. + +=cut + +sub run_cgi +{ + my ($self) = @_; + my $config = $self->{ _config }; + my $title = $config->{ ticket_cgi_title } || 'ticket system interface'; + my $color = $config->{ ticket_cgi_bgcolor } || '#E6E6FA'; + + # XXX $ml_name may change by HTTP request + $config->{ ml_name } = param('ml_name') if param('ml_name'); + + # ensure the current mode + $self->mode('html'); + + # load standard CGI routines + use CGI qw/:standard/; + + # get action parameter via HTTP + my $action = param('action') || 'list'; + my $ticket_id = param('ticket_id'); + + # o.k start html + print start_html(-title=>$title,-BGCOLOR=>$color), "\n"; + + if ($action eq 'close') { + $self->set_status({ + ticket_id => $ticket_id, + status => 'closed', + }); + } + + if ($action eq 'show') { + Log("run.cgi.show_articles for $ticket_id"); + $self->show_articles_for_ticket($ticket_id); + } + else { + # menu at the top of scrren + $self->cgi_top_menu(); + + # show summary + $self->show_summary(); + } + + # o.k. end of html + print end_html; + print "\n"; +} + + +1; diff --git a/fml/lib/Mail/ThreadTrack/Print/Text.pm b/fml/lib/Mail/ThreadTrack/Print/Text.pm new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/fml/lib/Mail/ThreadTrack/Print/Text.pm |