File Coverage

blib/lib/Mail/Qmail/Queue/Send.pm

Criterion	Covered	Total	%
statement	95	102	93.1
branch	35	72	48.6
condition	1	2	50.0
subroutine	20	22	90.9
pod	13	13	100.0
total	164	211	77.7

package Mail::Qmail::Queue::Send;
our $VERSION = 0.02;
#
# Copyright 2006 Scott Gifford
#
# This library is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

use warnings;
use strict;

use constant DEFAULT_QMAIL_QUEUE => '/var/qmail/bin/qmail-queue';
use constant QQ_ENV_FD => 1;
use constant QQ_BODY_FD => 0;

=head1 NAME

Mail::Qmail::Queue::Send - Send a message to a program implementing the qmail-queue interface

=head1 SYNOPSIS

  use Mail::Qmail::Queue::Send;

  my $qq = Mail::Qmail::Queue::Send->new()
      or die "Couldn't create qmail-queue sender: $!\n";

  $qq_send->body("Test message\n")
      or die "Couldn't write body: $!\n";

  $qq_send->from('[e-mail]')
      or die "Couldn't write envelope from: $!\n";
  $qq_send->to('[e-mail]')
      or die "Couldn't write envelope to #1: $!\n";
  $qq_send->to('[e-mail]')
      or die "Couldn't write envelope to #2: $!\n";
  $qq_send->envelope_done()
      or die "Couldn't finish writing envelope: $!\n";

  $qq_send->wait_exitstatus() == 0
      or die "Error sending message: exit status $?\n";

Note that the L specifications require that the body
be read first, then the envelope.

=cut

use POSIX;
use FileHandle;

use Mail::Qmail::Queue::Error qw(:errcodes :fail);

=head1 DESCRIPTION

This module sends a message to a program implementing the
L protocol.  You must send the body first,
then the envelope.

=head2 CONSTRUCTOR

=over 4

=item new ( %options )

Creates a new qmail-queue sender.  Executes C or the
equivalent, and sets up the file descriptors to prepare to talk to it.
If a C option is given, that will be used as the path to
the C program.  Otherwise, the contents of the
environment variable C will be used; if that is unset,
C is the default.

Available options are:

=over 4

=item QmailQueue

Specifies the path to the program that will handle the message.

=item LeaveEnvHandle

Do not open up file descriptor 1 to C's envelope reader;
instead the current process's file descriptor 1 will be connected to
it.  This is useful if you are writing a filter to change the body,
but want to leave the envelope alone.

=item LeaveBodyHandle

Do not open up file descriptor 0 to C's body reader;
instead the current process's file descriptor 0 will be connected to
it.  This is useful if you are writing a filter to change the
envelope, but want to leave the body alone.

=back

=back

=cut

sub new
{
    my $class = shift;
    my %o = @_;
    my $self = bless {}, $class;

    my $qq_path = $o{QmailQueue} || $ENV{QMAILQUEUE} || DEFAULT_QMAIL_QUEUE;
    $self->{_qq_pid} = $self->_start_qmail_queue($qq_path,\%o)
	or tempfail QQ_EXIT_NETFAIL, "Couldn't start up '$qq_path': $!\n";
    $self;
}

=head2 METHODS

=over 4

=item send ( $body, $from, @to )

Sends a complete message, and returns the exit status of the
C program.

=cut

sub send
{
    my $self = shift;
    $self->body(shift)
	or return undef;
    $self->from(shift)
	or return undef;
    $self->to(@_)
	or return undef;
    $self->envelope_done
	or return undef;
    return $self->wait_exitstatus;
}


=item body_fh ( )

Retrieves a Perl filehandle to which the message body can be written.

=cut

sub body_fh
{
    my $self = shift;
    return $self->{_msg_fh};
}

=item body_close ( )

Close the body filehandle.  You must use this when you're done sending
the body filehandle, to indicate to the C program that
you're done, and to tell this module that it's ready to accept the
envelope.

=cut

sub body_close
{
    my $self = shift;

    $self->{_body_sent}=1;
    return close($self->{_msg_fh});
}

=item body ( @body )

Send the provided string or strings as the complete body of the
message, closing the filehandle after sending it.

If you are working with a very large message, it may be more efficient
to write the body in smaller pieces to the filehandle returned by
C.

=cut

sub body
{
    my $self = shift;
    my $fh = $self->{_msg_fh}
        or tempfail QQ_EXIT_BUG,"Body filehandle not available!";
    print $fh @_
	or tempfail QQ_EXIT_WRITEERR,"Write error: $!\n";
    $self->body_close()
	or tempfail QQ_EXIT_WRITEERR,"Error closing write pipe: $!\n";
    return 1;
}

=item from ( $from )

Send the provided email address as the envelope from.  You must send
the body first.

=cut

sub from
{
    my $self = shift;

    my($from)=@_;
    $self->{_from}=$from;
    $self->put_envelope_entry('F'.$from);
}

=item to ( @to )

Send the provided email address or addresses as the envelope to.  You
must send the body and the envelope from first.

=cut

sub to
{
    my $self = shift;
    defined($self->{_from})
	or tempfail QQ_EXIT_BUG,"envelope from must be set before envelope to\n";
    $self->put_envelope_entry(map { 'T'.$_ } @_);
}

=item envelope_done ( )

Indicate that you have sent all of the envelope, and are now done.
The filehandle will be closed, and C will probably begin
processing the message.

=cut

sub envelope_done
{
    my $self = shift;
    $self->put_envelope_entry('')
	or return undef;
    my $fh = $self->{_env_fh}
        or tempfail QQ_EXIT_BUG, "No envelope filehandle\n";
    close($fh)
	or tempfail QQ_EXIT_WRITEERR,"Error closing envelope filehandle: $!\n";
    return 1;
}

=item put_envelope_entry ( @entries )

Send the provided envelope entries.  They must be properly formatted
entries, or else they will confuse the called C program.
The null character will be inserted between the entries by this
method, and you should not set it.

Note that if you use this method instead of C, you cannot use
the C method, because this module won't know that you've already
sent an envelope from.

L will
return strings that can be passed to this method.

=cut

sub put_envelope_entry
{
    my $self = shift;

    $self->envelope_write(join("\0",@_)."\0");
}

=item envelope_write ( @str )

Send the provided string or strings directly to the C
envelope filehandle.  This requires a knowledge of the
L protocol.

=cut

sub envelope_write
{
    my $self = shift;
    my $fh = $self->{_env_fh}
        or tempfail QQ_EXIT_BUG, "No envelope filehandle\n";
    return print $fh @_;
}

=item envelope_fh

Retrieve a Perl filehandle to which the message envelope can be
written.  Using this filehandle requires knowledge of the envelope
format; see L for details.

=cut

sub envelope_fh
{
    my $self = shift;
    return $self->{_env_fh};
}


=item wait_exitstatus ( )

Wait for the C program to finish, and return its exit
status.  If the program is killed by a signal, L
will be returned.

=cut

sub wait_exitstatus
{
    my $self = shift;

    $self->wait;
    if ($? == 0)
    {
	return 0;
    }
    elsif ($? >> 8)
    {
	return $? >> 8;
    }
    else
    {
	return QQ_EXIT_BUG;
    }
}

=item wait ( )

Wait for the C program to finish, and return the value
from C.

=cut

sub wait
{
    my $self = shift;
    waitpid($self->{_qq_pid},@_);
}

sub _start_qmail_queue
{
    my $self = shift;
    my($path,$o)=@_;
    my(@env_pipe,@body_pipe);

    unless ($o->{LeaveEnvHandle})
    {
	@env_pipe = POSIX::pipe()
	    or tempfail QQ_EXIT_WRITEERR, "Couldn't create envelope pipe: $!\n";
    }
    unless ($o->{LeaveMsgHandle})
    {
	@body_pipe = POSIX::pipe()
	    or tempfail QQ_EXIT_WRITEERR, "Couldn't create envelope pipe: $!\n";
    }

    my $f = fork();

    if (!defined($f))
    {
	tempfail QQ_EXIT_TEMPREFUSE, "Fork failed: $!\n";
    }
    elsif ($f)
    {
	# Parent
	if (@body_pipe)
	{
	    POSIX::close($body_pipe[0])
		or tempfail QQ_EXIT_READERR, "Couldn't close body pipe reader in parent: $!\n";
	    $self->{_msg_fh} = FileHandle->new_from_fd($body_pipe[1],"w")
		or tempfail QQ_EXIT_READERR, "Couldn't create FileHandle for body writer fd $body_pipe[1] in parent: $!\n";
	}
	if (@env_pipe)
	{
	    POSIX::close($env_pipe[0])
		or tempfail QQ_EXIT_READERR, "Couldn't close envelope pipe reader in parent: $!\n";
	    $self->{_env_fh} = FileHandle->new_from_fd($env_pipe[1],"w")
		or tempfail QQ_EXIT_READERR, "Couldn't create FileHandle for envelope pipe writer fd $env_pipe[1] in parent: $!\n";
	}
	return $f;
    }
    else
    {
	# Child
	if (@body_pipe)
	{
	    POSIX::close($body_pipe[1])
		or tempfail QQ_EXIT_WRITEERR, "Couldn't close body pipe writer in child: $!\n";
            POSIX::close(QQ_BODY_FD); # Ignore errors
	    POSIX::dup2($body_pipe[0],QQ_BODY_FD)
		or tempfail QQ_EXIT_WRITEERR, "Couldn't dup body pipe reader to fd 1 in child: $!\n";
	    POSIX::close($body_pipe[0])
		or tempfail QQ_EXIT_WRITEERR, "Couldn't close body pipe reader after dup in child: $!\n";
	}
	if (@env_pipe)
	{
	    POSIX::close($env_pipe[1])
		or tempfail QQ_EXIT_WRITEERR, "Couldn't close envelope pipe writer in child: $!\n";
            POSIX::close(QQ_ENV_FD); # Ignore errors
	    POSIX::dup2($env_pipe[0],QQ_ENV_FD)
		or tempfail QQ_EXIT_WRITEERR, "Couldn't dup envelope pipe reader to fd 0 in child: $!\n";
	    POSIX::close($env_pipe[0])
		or tempfail QQ_EXIT_WRITEERR, "Couldn't close envelope pipe reader after dup in child: $!\n";
	}
	exec($path)
	    or tempfail QQ_EXIT_TEMPREFUSE, "exec failed: $!\n";
    }
}

=back

=head1 SEE ALSO

L, L,
L, L.

=head1 COPYRIGHT

Copyright 2006 Scott Gifford.

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1;