File Coverage

blib/lib/Net/QMTP.pm

Criterion	Covered	Total	%
statement	71	218	32.5
branch	34	202	16.8
condition	1	9	11.1
subroutine	13	24	54.1
pod	12	12	100.0
total	131	465	28.1

package Net::QMTP;

require 5.001;
use strict;

use IO::Socket;
use Carp;
use Text::Netstring qw(netstring_encode netstring_decode netstring_read
		netstring_verify);

#
# Copyright (c) 2003 James Raftery . All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
# Please submit bug reports, patches and comments to the author.
# Latest information at http://romana.now.ie/#net-qmtp
#
# $Id: QMTP.pm,v 1.22 2004/11/02 14:56:18 james Exp $
#
# This module is an object interface to the Quick Mail Transfer Protocol
# (QMTP). QMTP is a replacement for the Simple Mail Transfer Protocol
# (SMTP). It offers increased speed, especially over high latency
# links, pipelining, 8-bit data transmission and predeclaration of
# line-ending encoding.
#
# See the Net::QMTP man page that was installed with this module for
# information on how to use the module. You require version 0.04 or
# later of the Text::Netstring module.
#

use vars qw($VERSION);
$VERSION = "0.06";

sub new {
	my $proto = shift or croak;
	my $class = ref($proto) || $proto;
	my $server = shift or croak "No server specified in constructor";
	my %args;

	%args = @_ if @_;
	my $self = {
		SENDER		=> undef,
		RECIPIENTS	=> [],
		MESSAGE		=> undef,
		MSGFILE		=> undef,
		ENCODING	=> undef,
		SOCKET		=> undef,
		SERVER		=> undef,
		PORT		=> 209,
		DEBUG		=> undef,
		TIMEOUT		=> undef,	# use IO::Socket default
		CONNECTTIME	=> undef,
		SESSIONLIMIT	=> 3600,	# 1 hour
	};
	if ($args{'Debug'}) {
		$self->{DEBUG} = 1;
		warn "debugging on; Version: $VERSION; RCS " .
			qq$Revision: 1.22 $ . "\n";
	}
	$self->{SERVER} = $server or croak "Constructor server failed";
	warn "server set to '$server'\n" if $self->{DEBUG};
	bless($self, $class);
	unless ($self->encoding("__GUESS__")) {
		carp "Constructor encoding() failed";
		return undef;
	}
	if ($args{'ConnectTimeout'}) {
		$self->{TIMEOUT} = $args{'ConnectTimeout'};
		warn "timeout ".$self->{TIMEOUT}."\n" if $self->{DEBUG};
	}
	if ($args{'Port'}) {
		$self->{PORT} = $args{'Port'};
		warn "port set to ".$self->{PORT}."\n" if $self->{DEBUG};
	}
	unless ($args{'DeferConnect'}) {
		warn "calling reconnect()\n" if $self->{DEBUG};
		$self->reconnect() or return undef;
	}
	warn "constructor finished\n" if $self->{DEBUG};
	return $self;
}

sub reconnect {
	my $self = shift;
	ref($self) or croak;

	my $sock = $self->{SOCKET};

	# if have a socket, disconnect first
	if (defined($sock)) {
		#carp "Socket is already defined";
		#return undef;
		$self->disconnect() or return undef;
	}

	# Applying timeout() to socket seems to fail. Hmm.
	warn "opening socket to " . $self->{SERVER} . "\n" if $self->{DEBUG};
	if ($self->{TIMEOUT}) {
		warn "socket timeout ".$self->{TIMEOUT}."\n" if $self->{DEBUG};
		$sock = IO::Socket::INET->new(
				PeerAddr	=> $self->{SERVER},
				PeerPort	=> $self->{PORT},
				Timeout		=> $self->{TIMEOUT},
				Proto		=> 'tcp') or return undef;
	} else {
		warn "socket default timeout\n" if $self->{DEBUG};
		$sock = IO::Socket::INET->new(
				PeerAddr	=> $self->{SERVER},
				PeerPort	=> $self->{PORT},
				Proto		=> 'tcp') or return undef;
	}

	binmode($sock);
	$self->{SOCKET} = $sock;
	$sock->autoflush();
	warn "socket opened to " . $sock->peerhost() . "\n" if $self->{DEBUG};
	$self->{CONNECTTIME} = time;
	warn "connected at " . $self->{CONNECTTIME} . "\n" if $self->{DEBUG};
	return $self->{SOCKET};
}

sub disconnect {
	my $self = shift;
	ref($self) or croak;

	my $sock = $self->{SOCKET};

	# can't disconnect if no socket
	if (!defined($sock)) {
		carp "Socket is not defined";
		return undef;
	}

	##
	## Only on newer perls
	##
	### can't disconnect if not connected
	##if (!$sock->connected()) {
	##	carp "Socket is not connected";
	##	$self->{SOCKET} = undef;
	##	return undef;
	##}

	warn "closing socket to " . $sock->peerhost() . "\n" if $self->{DEBUG};
	unless (close $sock) {
		carp "Cannot close socket: $!";
		return undef;
	}
	$self->{SOCKET} = undef;
	warn "socket closed (was open for " . (time - $self->{CONNECTTIME}) .
				"s)\n" if $self->{DEBUG};
	return 1;
}

sub encoding {
	my $self = shift;
	ref($self) or croak;
	my $e = shift or return $self->{ENCODING};

	# guess from input record seperator
	if ($e eq "__GUESS__") {
		warn "guessing encoding\n" if $self->{DEBUG};
		if ($/ eq "\015\012") {		# CRLF: Dos/Win
			$self->{ENCODING} = "\015";
			warn "guessed carraige-return encoding\n" if $self->{DEBUG};
		} else {			# LF: Unix-like
			$self->{ENCODING} = "\012";
			warn "guessed line-feed encoding\n" if $self->{DEBUG};
		}

	# specific encoding requested
	} elsif ($e eq "dos") {
		$self->{ENCODING} = "\015";
		warn "set carraige-return encoding\n" if $self->{DEBUG};
	} elsif ($e eq "unix") {
		$self->{ENCODING} = "\012";
		warn "set line-feed encoding\n" if $self->{DEBUG};
	} else {
		croak "Unknown encoding: '$e'";
		$self->{ENCODING} = undef;
	}

	return $self->{ENCODING};
}

sub server {
	my $self = shift;
	ref($self) or croak;
	$self->{SERVER} = shift if @_;
	warn "server is " . $self->{SERVER} . "\n" if $self->{DEBUG};
	return $self->{SERVER};
}

sub sender {
	my $self = shift;
	ref($self) or croak;
	$self->{SENDER} = shift if @_;
	warn "sender is " . $self->{SENDER} . "\n" if $self->{DEBUG};
	return $self->{SENDER};
}

sub recipient {
	my $self = shift;
	ref($self) or croak;
	push(@{$self->{RECIPIENTS}}, shift) if @_;
	warn "recipients are ". join(",", @{$self->{RECIPIENTS}}) .
			"\n" if $self->{DEBUG};
	return $self->{RECIPIENTS};
}

sub message {
	my $self = shift;
	ref($self) or croak;
	warn "message() started\n" if $self->{DEBUG};
	if ($self->{MSGFILE}) {
		carp "Message already created by message_from_file()";
		return undef;
	}
	$self->{MESSAGE} .= shift if @_;
	warn "message text appended (is now " . length($self->{MESSAGE}) .
				" bytes)\n" if $self->{DEBUG};
	return $self->{MESSAGE};
}

sub message_from_file {
	my $self = shift;
	ref($self) or croak;
	warn "message_from_file() started\n" if $self->{DEBUG};
	if (defined($self->{MESSAGE})) {
		carp "Message already created by message()";
		return undef;
	}
	my $f = shift or return $self->{MSGFILE};
	#
	# This is permitted in case the file needs to be created/modified
	# by some subsequent process
	## -f $f or return undef;
	#
	warn "message_from_file file is '$f'\n" if $self->{DEBUG};
	$self->{MSGFILE} = $f;
	return $self->{MSGFILE};
}

sub new_message {
	my $self = shift;
	ref($self) or croak;

	$self->{MESSAGE} = undef;
	$self->{MSGFILE} = undef;
	warn "message reset\n" if $self->{DEBUG};
	return 1;
}

sub new_envelope {
	my $self = shift;
	ref($self) or croak;

	$self->{SENDER} = undef;
	$self->{RECIPIENTS} = [];
	warn "envelope reset\n" if $self->{DEBUG};
	return 1;
}

sub _send_file {
	my $self = shift;
	ref($self) or die;
	my $f = $self->{MSGFILE};
	my $sock = $self->{SOCKET};

	warn "_send_file starting\n" if $self->{DEBUG};
	unless (open(FILE, $f)) {
		carp "Cannot open file '$f': $!";
		return undef;
	}
	my $size = (stat(FILE))[7];
	binmode(FILE);
	#carp "File '$f' is empty" if $size == 0;
	if ($size < 0) {
		carp "File '$f' has negative size";
		return undef;
	}

	my $len;
	print $sock ($size+1) . ":" . $self->{ENCODING} or return undef;
	while () { print $sock $_ or return undef; $len += length($_) };

	if ($size != $len) {
		warn "File '$f' should be $size but we read $len\n";
		return undef;
	}
	print $sock "," or return undef;
	unless (close FILE) {
		carp "Cannot close file '$f': $!";
		return undef;
	}
	warn "_send_file finished\n" if $self->{DEBUG};
	return 1;
}

sub send {
	my $self = shift;
	ref($self) or croak;

	warn "send() running sanity checks\n" if $self->{DEBUG};
	$self->_ready_to_send() or return undef;
	##$self->_session_notexpired() or return undef;
	my $sock = $self->{SOCKET};

	if ($self->{MSGFILE}) {
		warn "calling _send_file for " . $self->{MSGFILE} .
				"\n" if $self->{DEBUG};
		$self->_send_file() or return undef;
	} else {
		warn "sending message data\n" if $self->{DEBUG};
		print $sock netstring_encode($self->{ENCODING} .
			$self->{MESSAGE}) or return undef;
	}

	my($s, %r);

	$s = netstring_encode($self->{SENDER});
	warn "sending envelope sender $s\n" if $self->{DEBUG};
	print $sock $s or return undef;

	$s = netstring_encode(scalar netstring_encode($self->{RECIPIENTS}));
	warn "sending envelope recipient(s) $s\n" if $self->{DEBUG};
	print $sock $s or return undef;

	$s = undef;
	foreach (@{$self->{RECIPIENTS}}) {
		warn "read response\n" if $self->{DEBUG};
		$s = $self->_read_netstring();
		warn "parse response: $s\n" if $self->{DEBUG};
		CASE: {
			$s =~ s/^K/success: / and last CASE;
			$s =~ s/^Z/deferral: / and last CASE;
			$s =~ s/^D/failure: / and last CASE;
			_badproto();
		}
		$r{$_} = $s;
	}

	warn "finished send()\n" if $self->{DEBUG};
	return \%r;
}

sub _ready_to_send {
	my $self = shift;
	ref($self) or die;

	warn "_ready_to_send() starting\n" if $self->{DEBUG};
	# need defined sender (don't need true; empty string valid),
	# recipient(s), defined message, socket and an encoding
	return (defined($self->{SENDER}) and scalar(@{$self->{RECIPIENTS}}) and
		(defined($self->{MESSAGE}) or $self->{MSGFILE}) and
		$self->{SOCKET} and $self->{ENCODING});
}

sub _session_notexpired {
	my $self = shift;
	ref($self) or die;

	if (time - $self->{CONNECTTIME} > $self->{SESSIONLIMIT}) {
		carp "Session has expired";
		$self->disconnect();	# what about failure?
		return undef;
	}
	return 1;
}

sub _read_netstring {
	my $self = shift;
	ref($self) or die;
	my $sock = $self->{SOCKET};

	my $s = netstring_read($sock);

	if (defined $s and netstring_verify($s)) {
		return netstring_decode($s);
	}
	return "";
}

sub _badproto {
	confess "Protocol violation\n";
}

sub _badresources {
	confess "Excessive resources requested\n";
}

sub DESTROY {
	my $self = shift;
	ref($self) or die;
	$self->disconnect() if $self->{SOCKET};	# don't care about failure
}

1;

__END__