restructure qmail-ext command emulation.

currently libexec/error traps the request and switch the context to
command process. FML::Process::QMail no more used.
FML::Command::QmailExt provides qmail-ext emulation functions.

3 files changed, 358 insertions, 126 deletions

diff --git a/fml/lib/FML/Command/QmailExt.pm b/fml/lib/FML/Command/QmailExt.pm
new file mode 100644
index 00000000..b1b42290
--- /dev/null
+++ b/fml/lib/FML/Command/QmailExt.pm
@@ -0,0 +1,304 @@
+#-*- perl -*-
+#
+#  Copyright (C) 2006 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.10 2006/01/07 13:16:41 fukachan Exp $
+#
+
+package FML::Command::QmailExt;
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD);
+use Carp;
+
+=head1 NAME
+
+FML::Command::QmailExt - qmail-ext style command emulator.
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 new()
+
+constructor.
+
+=cut
+
+
+# Descriptions: constructor.
+#    Arguments: OBJ($self) OBJ($curproc)
+# Side Effects: none
+# Return Value: OBJ
+sub new
+{
+    my ($self, $curproc) = @_;
+    my ($type) = ref($self) || $self;
+    my $me     = { _curproc => $curproc };
+    return bless $me, $type;
+}
+
+
+=head2 match($extension)
+
+Environment variable EXT holds extention information.
+for example, a mail to ML-subscribe@VIRTUAL.DOMAIN is recognized as
+extension with "VIRTUAL.DOMAIN-ML-subscribe" in EXT variable.
+
+=cut
+
+
+# Descriptions: check if $extension string look a qmail extension command.
+#    Arguments: OBJ($self) STR($extension)
+# Side Effects: none
+# Return Value: NUM
+sub match
+{
+    my ($self, $extension) = @_;
+    my $curproc = $self->{ _curproc };
+
+    # ASSERT
+    unless (defined $extension) { return 0;}
+    unless ($extension)         { return 0;}
+
+    # 1. parse command normally.
+    my ($found, $command) = $self->_parse_extension($extension);
+    $curproc->logdebug("qmail-ext: @$command");
+
+    # 2. admin command special handling.
+    # XXX VERPs and admin command looks same.
+    # need more care for admin command, which is an exception.
+    my ($main_command, $sub_command) = @$command;
+    if ($main_command eq 'admin') {
+	if ($sub_command =~ /^[a-z0-9]+$/i) {
+	    $curproc->logdebug("qmail-ext: looks admin command");
+	}
+	else {
+	    $curproc->logdebug("qmail-ext: not looks admin command");
+	    $found = 0;
+	}
+    }
+
+    return $found;
+}
+
+
+# Descriptions: parse extension string.
+#               return status and command list as ARRAY_REF.
+#    Arguments: OBJ($self) STR($extension)
+# Side Effects: none
+# Return Value: ARRAY(NUM, ARRAY_REF)
+sub _parse_extension
+{
+    my ($self, $extension) = @_;
+    my $curproc   = $self->{ _curproc };
+    my $config    = $curproc->config();
+    my $ml_name   = $curproc->ml_name();
+    my $ml_domain = $curproc->ml_domain();
+    my $anonymous_command_list =
+	$config->get_as_array_ref('anonymous_command_mail_allowed_commands');
+    my $user_command_list =
+	$config->get_as_array_ref('user_command_mail_allowed_commands');
+
+    # extension is VIRTUAL.DOMAIN-ML-COMMAND-ARGUMENTS format.
+    my (@command) = ();
+    my $found     = 0;
+  COMMAND:
+    for my $command (@$anonymous_command_list, @$user_command_list) {
+	my $pattern = sprintf("%s-%s-%s", $ml_domain, $ml_name, $command);
+	if ($extension =~  /^($pattern)$|^($pattern)\-/i) {
+	    my $argv = $self->_parse_argv($extension, $pattern);
+	    (@command) = ($command, @$argv);
+	    $found = 1;
+	    last COMMAND;
+	}
+    }		     
+
+    if ($found) {
+	return($found, \@command);
+    }
+    else {
+	return(0, []);
+    }
+}
+
+
+# Descriptions: parse arguments and return it as ARRAY_REF.
+#    Arguments: OBJ($self) STR($extension) STR($pattern)
+# Side Effects: none
+# Return Value: ARRAY_REF
+sub _parse_argv
+{
+    my ($self, $extension, $pattern) = @_;
+
+    my $argv = $extension;
+    $argv =~ s/^$pattern//;
+    $argv =~ s/^\-//;
+    $argv =~ s/\-\-/\@/g; # XXX @ is unavaialble string. useful for swapping.
+    $argv =~ s/\-/ /g;
+    $argv =~ s/\@/-/g;
+    $argv =~ s/=/\@/g;
+
+    if ($argv) {
+	my (@argv) = split(/\s+/, $argv);
+	return \@argv;
+    }
+    else {
+	return [];
+    }
+}
+
+
+=head2 execute($extension)
+
+emulate command process.
+
+=cut
+
+
+# Descriptions: emulate command process.
+#    Arguments: OBJ($self) STR($extension)
+# Side Effects: bootstrap FML::Process::Command emulation.
+# Return Value: none
+sub execute
+{
+    my ($self, $extension) = @_;
+    my $curproc = $self->{ _curproc };
+
+    # ASSERT
+    unless (defined $extension) { return 0;}
+    unless ($extension)         { return 0;}
+
+    # 1. parse extension to extract a command (ARRAY_REF).
+    my ($found, $command) = $self->_parse_extension($extension);
+    $curproc->log("qmail-ext: emulate command: @$command");
+
+    # 2. fake a command request message.
+    # 2.1 message header is same as the current message.
+    # 2.2 message body is $command.
+    my $msg_file = $self->_construct_request_mail($command);
+    unless (defined $msg_file) {
+	$curproc->logerror("command execution stop");
+	return;
+    }
+
+    # 3. close STDIO. re-open STDIO for our faked message.
+    my $status = $self->_reopen_stdio_channel($msg_file);
+    unless ($status) {
+	$curproc->logerror("cannot re-open STDIO.");
+	$curproc->logerror("command execution stop");
+	return;
+    }
+
+    # 4. run a new process context by NewProcess() call.
+    $self->_execute_new_process();
+}
+
+
+# Descriptions: create a temporary request message.
+#    Arguments: OBJ($self) ARRAY_REF($command)
+# Side Effects: none
+# Return Value: STR
+sub _construct_request_mail
+{
+    my ($self, $command) = @_;
+    my $curproc = $self->{ _curproc };
+    my $header  = $curproc->incoming_message_header();
+
+    # create a new faked message file.
+    use FileHandle;
+    my $message_file = $curproc->tmp_file_path();
+    my $wh = new FileHandle "> $message_file";
+    if (defined $wh) {
+	$wh->autoflush(1);
+	$header->print($wh);
+	print $wh "\n";
+	print $wh join(" ", @$command), "\n";
+	$wh->close();
+    }
+    else {
+	$curproc->logerror("cannot open tmp file: $message_file");
+	return undef;
+    }
+
+    return $message_file;
+}
+
+
+# Descriptions: close and re-open STDIN
+#    Arguments: OBJ($self) STR($message_file)
+# Side Effects: close and re-open STDIN
+# Return Value: NUM
+sub _reopen_stdio_channel
+{
+    my ($self, $message_file) = @_;
+
+    close(STDIN);
+    my $status = open(STDIN, $message_file);
+    return( $status ? 1 : 0 ); 
+}
+
+
+# Descriptions: emulate execution of command mail process.
+#    Arguments: OBJ($self)
+# Side Effects: execute a new process.
+# Return Value: none
+sub _execute_new_process
+{
+    my ($self)    = @_;
+    my $curproc   = $self->{ _curproc };
+    my $myname    = "command";
+    my $ml_name   = $curproc->ml_name();
+    my $ml_domain = $curproc->ml_domain();
+
+    $curproc->logdebug("emulate $myname for $ml_name\@$ml_domain ML");
+
+    my $hints = {
+	config_overload => {
+	    'use_incoming_mail_header_loop_check' => 'no',
+	},
+    };
+
+    eval q{
+	use FML::Process::Switch;
+	&FML::Process::Switch::NewProcess($curproc,
+					  $myname,
+					  $ml_name,
+					  $ml_domain,
+					  $hints);
+    };
+    if ($@) {
+	$curproc->logerror($@);
+    }
+
+    $curproc->logdebug("emulation done");
+}
+
+
+=head1 CODING STYLE
+
+See C<http://www.fml.org/software/FNF/> on fml coding style guide.
+
+=head1 AUTHOR
+
+Ken'ichi Fukamachi
+
+=head1 COPYRIGHT
+
+Copyright (C) 2006 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
+
+FML::Command::QmailExt appeared in fml8 mailing list driver package.
+See C<http://www.fml.org/> for more details.
+
+=cut
+
+
+1;
diff --git a/fml/lib/FML/Process/Error.pm b/fml/lib/FML/Process/Error.pm
index 5c54366e..e6316a98 100644
--- a/fml/lib/FML/Process/Error.pm
+++ b/fml/lib/FML/Process/Error.pm
@@ -3,7 +3,7 @@
 # Copyright (C) 2002,2003,2004,2005,2006 Ken'ichi Fukamachi
 #          All rights reserved.
 #
-# $FML: Error.pm,v 1.55 2005/11/30 23:50:19 fukachan Exp $
+# $FML: Error.pm,v 1.56 2006/02/15 13:44:04 fukachan Exp $
 #
 
 package FML::Process::Error;
@@ -158,6 +158,12 @@ sub run
     my $eval = $config->get_hook( 'error_mail_analyzer_run_start_hook' );
     if ($eval) { eval qq{ $eval; }; $curproc->logwarn($@) if $@; }
 
+    if ($curproc->_is_qmail_extension_command()) {
+	$curproc->_execute_qmail_extension_command();
+	$pcb->set("qmail-ext", "found", 1);
+	goto END; # no more normal error handling process.
+    }
+
     $curproc->_forward_error_message();
 
     unless ($curproc->is_refused()) {
@@ -199,6 +205,7 @@ sub run
 	}
     }
 
+  END:
     $eval = $config->get_hook( 'error_mail_analyzer_run_end_hook' );
     if ($eval) { eval qq{ $eval; }; $curproc->logwarn($@) if $@; }
 }
@@ -283,6 +290,9 @@ sub finish
     if ($pcb->get("error", "found")) {
 	$curproc->log("error message found");
     }
+    elsif ($pcb->get("qmail-ext", "found")) {
+	$curproc->logdebug("qmail-ext found");
+    }
     else {
 	$curproc->logwarn("error message not found");
     }
@@ -335,6 +345,49 @@ sub _forward_error_message
 }
 
 
+=head1 QMAIL EXTENSION COMMAND TRAP
+
+In qmail environment, you can use the following address as a command:
+<elena-subscribe@domain> for subscribe request for elena@domain ML.
+
+To emulate this special command mail request, libexec/error need to
+check EXT environment variable and pass the control to
+FML::Process::Command if needed.
+
+=cut
+
+
+# Descriptions: we receive qmail extension command or not ?
+#    Arguments: OBJ($curproc)
+# Side Effects: none
+# Return Value: NUM
+sub _is_qmail_extension_command
+{
+    my ($curproc) = @_;
+
+    # environment variable EXT holds extention information.
+    # for example, a mail to ML-subscribe@VIRTUAL.DOMAIN is recognized as
+    # extension with "VIRTUAL.DOMAIN-ML-subscribe" in EXT variable.
+    use FML::Command::QmailExt;
+    my $extension = new FML::Command::QmailExt $curproc;
+    return $extension->match($ENV{EXT});
+}
+
+
+# Descriptions: execute qmail extension command emulation.
+#    Arguments: OBJ($curproc)
+# Side Effects: emulate command process if needed.
+# Return Value: none
+sub _execute_qmail_extension_command
+{
+    my ($curproc) = @_;
+
+    use FML::Command::QmailExt;
+    my $extension = new FML::Command::QmailExt $curproc;
+    $extension->execute($ENV{EXT});
+}
+
+
 =head1 CODING STYLE
 
 See C<http://www.fml.org/software/FNF/> on fml coding style guide.
diff --git a/fml/lib/FML/Process/QMail.pm b/fml/lib/FML/Process/QMail.pm
deleted file mode 100644
index b52e44a7..00000000
--- a/fml/lib/FML/Process/QMail.pm
+++ /dev/null
@@ -1,125 +0,0 @@
-#-*- perl -*-
-#
-#  Copyright (C) 2001,2002,2003,2004 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: QMail.pm,v 1.21 2004/03/12 04:22:56 fukachan Exp $
-#
-
-package FML::Process::QMail;
-use strict;
-use Carp;
-use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD);
-
-
-# Descriptions: standard contructor
-#    Arguments: OBJ($self)
-# Side Effects: none
-# Return Value: OBJ
-sub new
-{
-    my ($self) = @_;
-    my ($type) = ref($self) || $self;
-    my $me     = {};
-    return bless $me, $type;
-}
-
-
-=head1 NAME
-
-FML::Process::QMail - emulate C<qmail-ext> address such as elena-subscribe@
-
-=head1 SYNOPSIS
-
-C<NOT YET IMPLERMENTED>.
-
-=head1 DESCRIPTION
-
-C<NOT YET IMPLERMENTED>.
-
-=head1 TODO
-
-   XXX
-   XXX MEMO on TODO
-   XXX
-
-   we should not use "# command" representation even though internally.
-
-   check $ext more restrictly.
-
-=head1 METHODS
-
-=cut
-
-#
-# XXX-TODO: NOT YET IMPLERMENTED.
-#
-
-
-# Descriptions: qmail style command extention
-#               elena-subscribe@domain implies
-#               "mail message body with subscribe to elena-ctl@domain"
-#    Arguments: OBJ($curproc)
-# Side Effects: none
-# Return Value: STR
-sub DotQmailExt
-{
-    my ($curproc) = @_;
-    my $config    = $curproc->config();
-
-    # get ?
-    my $ext = $ENV{'EXT'};
-
-    unless ($ext) {
-	$curproc->log("no extension address");
-	return;
-    }
-
-    &$curproc->log("dot-qmail-ext[0]: $ext");
-    my ($key)    = (split(/\@/, $config->{ article_post_address }))[0];
-    my ($keyctl) = (split(/\@/, $config->{ command_mail_address }))[0];
-
-    if ($ext =~ /^($key)$/i) {
-	return '';
-    }
-    elsif ($keyctl&& ($ext =~ /^($keyctl)$/i)) {
-	return '';
-    }
-
-    $curproc->log("dot-qmail-ext: $ext");
-    $ext =~ s/^$key//i;
-    $ext =~ s/\-\-/\@/i; # since @ cannot be used
-    $ext =~ s/\-/ /g;
-    $ext =~ s/\@/-/g;
-    $curproc->log("\$ext -> $ext");
-
-    # XXX: "# command" is internal represention
-    return sprintf("# %s", $ext);
-}
-
-
-=head1 CODING STYLE
-
-See C<http://www.fml.org/software/FNF/> on fml coding style guide.
-
-=head1 AUTHOR
-
-Ken'ichi Fukamachi
-
-=head1 COPYRIGHT
-
-Copyright (C) 2001,2002,2003,2004 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
-
-FML::Process::QMail first appeared in fml8 mailing list driver package.
-See C<http://www.fml.org/> for more details.
-
-=cut
-
-
-1;