File Coverage

blib/lib/News/NNTPClient.pm

Criterion	Covered	Total	%
statement	192	302	63.5
branch	35	120	29.1
condition	28	82	34.1
subroutine	48	60	80.0
pod	42	55	76.3
total	345	619	55.7

package News::NNTPClient;

require 5.002;

use Carp;
use Socket qw(1.5 inet_aton pack_sockaddr_in PF_INET SOCK_STREAM AF_INET);

use strict qw(vars subs);
use vars qw($VERSION $fhcnt);

$fhcnt = 0;			# File handle counter, to insure unique socket.
$VERSION = (qw$Revision: 0.37 $)[1];

# Create a new NNTP object.  Set up defaults for host and port, and
# attempt connection.  For host, if not supplied, check the
# environment variable NNTPSERVER.  If that isn't set, then hostname
# is "news".  For port, check the environment variable NNTPPORT, or
# use "nntp" service or 119.
sub new {
    my $name = shift;
    my $host = shift || $ENV{NNTPSERVER} || "news";
    my $port = shift || $ENV{NNTPPORT} || getservbyname("nntp","tcp") || 119;
    my $debug = shift;

    my $me = bless {
	DBUG => defined ($debug) ? $debug : 1,
	SOCK => $name . "::SOCK" . ++$fhcnt,
	HOST => $host,
	PORT => $port,
	ADDR => "",
	MESG => "",
	CODE => 0,
	POST => undef,
	EOL  => "\n",		# End Of Line
	GMT  => 0,		# Greenwich Mean Time
        FDY  => 0,		# Four Digit Year
    }, $name;

    $me->initialize();

    $me;
}

sub initialize {
    my $me = shift;

    $me->port($me->{PORT}) and
    $me->host($me->{HOST}) and
    $me->connect           and
    $me->response;
}

# Determine port number.  If we were passed a non-numeric port,
# attempt to look it up.
sub port {
    my $me = shift;
    my $port = shift or return $me->{PORT};

    unless ($port =~ /^\d+$/) {
	my $tmp = getservbyname ($port, "tcp") or
	    carp "News::NNTPClient: Bad port: $port" and return;
	$port = $tmp;
    }

    $me->{PORT} = $port;
}

# Resolve hostname.
sub host {
    my $me = shift;
    my $host = shift or return $me->{HOST};
    my $addr;

    # Get address.
    $addr = inet_aton($host) or
      carp "News::NNTPClient: Bad hostname: $host" and return;

    $me->{ADDR} = $addr;

    # Get fully qualified domain name if possible
    $me->{HOST} = gethostbyaddr ($addr, AF_INET) || $host;
}

# Connect to server.
sub connect {
    my $me = shift;

    my $SOCK = $me->{SOCK};

    if (defined fileno $SOCK) {
	1 < $me->{DBUG} and
	    warn "$SOCK already connected, closing\n";
	close $SOCK;
    }

    1 < $me->{DBUG} and
	warn "$SOCK connecting to $me->{HOST}:$me->{PORT}\n";

    socket ($SOCK, PF_INET, SOCK_STREAM, getprotobyname("tcp") || 6) or
	carp "News::NNTPClient: Can't open socket: $!" and return;

    unless (connect($SOCK, pack_sockaddr_in($me->{PORT},$me->{ADDR}))) {
	carp "News::NNTPClient: Can't connect socket: $!";
	close $SOCK;
	return;
    }

    select ((select($SOCK), $|=1)[0]); # Turn on autoflush.

    1;
}

########################################################################
# Helper methods.  These methods may be called to return saved
# information about the NNTP connection, information about the
# package, or to set EOL and debug,
########################################################################


# Return version number.
sub version {
    my $me = shift;

    # Get News::NNTPClient::version, if package happens to be
    # News::NNTPClient.
    my $rev = ${ref($me) . "::VERSION"};

    $rev;
}

# With no argument, return debugging level, otherwise set it.
sub debug {
    my $me = shift;
    my $debug = shift;

    $me->{DBUG} = $debug if defined $debug;

    $me->{DBUG};
}

# Set EOL
sub eol {
    my $me = shift;
    my $new = shift;
    my $old = $me->{EOL};

    # Set to new EOL only if passed a value.
    $me->{EOL} = $new if defined $new;

    $old;
}

# Set GMT
sub gmt {
    my $me = shift;
    my $new = shift;
    my $old = $me->{GMT};

    # Set to new GMT only if passed a value.
    $me->{GMT} = $new if defined $new;

    $old;
}

# Set Four digit year flag.
sub fourdigityear {
    my $me = shift;
    my $new = shift;
    my $old = $me->{FDY};

    # Set to new FDY only if passed a value.
    $me->{FDY} = $new if defined $new;

    $old;
}

# Return boolean according to code < 400.
sub ok {
    my $me = shift;

    # Codes less than 400 are good.
    0 < $me->{CODE} and $me->{CODE} < 400;
}

# Return boolean according to code < 400 and print message if not ok.
sub okprint {
    my $me = shift;

    warn "NNTPERROR: $me->{CODE} $me->{MESG}\n"
	if 400 <= $me->{CODE} and $me->{DBUG};

    # Codes less than 400 are good.
    0 < $me->{CODE} and $me->{CODE} < 400;
}

# Return the most recent message
sub message {
    my $me = shift;

    "$me->{MESG}$me->{EOL}";
}

# Return the most recent code
sub code {
    my $me = shift;

    $me->{CODE};
}

# Return boolean according to post ok flag.
sub postok {
    my $me = shift;

    $me->{POST};
}

########################################################################
# NNTP methods.
########################################################################

# Fetch an article.
sub article {
    my $me = shift;
    my $msgid = shift || "";

    $me->{CMND} = "fetch";
    $me->command("ARTICLE $msgid");
}

# Fetch body of an article.
sub body {
    my $me = shift;
    my $msgid = shift || "";

    $me->{CMND} = "fetch";
    $me->command("BODY $msgid");
}

# Fetch header of an article.
sub head {
    my $me = shift;
    my $msgid = shift || "";

    $me->{CMND} = "fetch";
    $me->command("HEAD $msgid");
}

# Fetch status of an article.  Return Message-ID if found.
sub stat {
    my $me = shift;
    my $msgid = shift || "";

    $me->{CMND} = "msgid";
    $me->command("STAT $msgid");
}

# Move current article pointer backwards.  Return Message-ID if found.
sub last {
    my $me = shift;

    $me->{CMND} = "msgid";
    $me->command("LAST");
}

# Move current article pointer forwards.  Return Message-ID if found.
sub next {
    my $me = shift;

    $me->{CMND} = "msgid";
    $me->command("NEXT");
}

# Set the group.
sub group {
    my $me = shift;
    my $group = shift || "";

    $me->{CMND} = "groupinfo";
    $me->command("GROUP $group");
}

# List all groups.
sub list {
    my $me   = shift;
    my $type = shift || "";
    my $pat  = shift || "";

    $me->{CMND} = "fetch";
    $me->command("LIST $type $pat");
}

# List new groups since date/time.
sub newgroups {
    my $me = shift;
    my $since = $me->yymmdd_hhmmss(shift);

    my $dist = distributions(@_);

    $me->{CMND} = "fetch";
    $me->command("NEWGROUPS $since $dist");
}

# List new news since date/time.  If first argument is a timestamp
# instead of a group, use default group.  Otherwise use second
# argument for time stamp.  Default group is set by the group method,
# or is all groups (*) if not set.
sub newnews {
    my $me = shift;
    my $group = shift;
    my $since;

    if ($group) {
	if ($group =~ /^[\d ]+/) {
	    $since = $group;
	    $group = "";
	} else {
	    $since = shift;
	}
    }

    $group ||= $me->{GROUP} || "*";
    $since = $me->yymmdd_hhmmss($since);

    my $dist = distributions(@_);

    $me->{CMND} = "fetch";
    $me->command("NEWNEWS $group $since $dist");
}

# Get help text.
sub help {
    my $me = shift;

    $me->{CMND} = "fetch";
    $me->command("HELP");
}

# Post an article.
sub post {
    my $me = shift;

    $me->command("POST") or return;

    $me->squirt(@_);
}

# Transfer an article.
sub ihave {
    my $me = shift;
    my $msgid = shift || "";

    $me->command("IHAVE $msgid") or return;

    $me->squirt(@_);
}

# Authinfo command
sub authinfo {
    my $me = shift;
    my $user = shift || "guest";
    my $pass = shift || "foobar";

    $me->command("AUTHINFO USER $user") && $me->command("AUTHINFO PASS $pass");
}

# Turn on slave mode, whatever that means.
sub slave {
    my $me = shift;

    $me->command("SLAVE");
}

# All done.
sub quit {
    my $me = shift;

    return unless defined fileno $me->{SOCK};

    my $ret = $me->command("QUIT");

    close $me->{SOCK};

    $ret;
}

sub DESTROY {
    my $me = shift;

    $me->quit;
}

########################################################################
# Extended NNTP methods.  Not all of these are implemented on all
# servers.
########################################################################

# Mode reader command.
sub mode_reader {
    my $me = shift;

    $me->command("MODE READER");
}

# Returns date
sub date {
    my $me = shift;

    $me->{CMND} = "msg";
    $me->command("DATE");
}

# Return list of article numbers in group.
sub listgroup {
    my $me = shift;
    my $group = shift || "";

    $me->{CMND} = "fetch";
    $me->command("LISTGROUP $group");
}

# Get message of the day.
sub xmotd {
    my $me = shift;
    my $since = $me->yymmdd_hhmmss(shift);

    $me->{CMND} = "fetch";
    $me->command("XMOTD $since");
}

# Return titles for newsgroups matching pattern.
sub xgtitle {
    my $me = shift;
    my $group_pattern = shift || "";

    $me->{CMND} = "fetch";
    $me->command("XGTITLE $group_pattern");
}

# Return path name for article?
sub xpath {
    my $me = shift;
    my $msgid = shift || "";

    $me->{CMND} = "msg";
    $me->command("XPATH $msgid");
}

# Fetch a header for a range of articles.  If ARG1 is numeric, use it
# as first entry of article range and use Message-ID as the header.
# Otherwise ARG1 is header, and ARG2 is first entry of article range.
sub xhdr {
    my $me = shift;
    my $header = shift || "message-id";
    my $list = shift || 1;
    my $last = shift;

    $list = "$list-$last" if $last;

    $me->{CMND} = "fetch";
    $me->command("XHDR $header $list");
}

sub xpat {
    my $me = shift;
    my $header = shift || "subject";
    my $list = shift || 1;
    my $last = shift;
    my $patterns = "";

    if ($last) {
	if ($last =~ /^\d+$/) {
	    $list = "$list-$last";
	} else {
	    $patterns = $last;
	}
    }

    $patterns .= @_ ? " @_" : "";

    $patterns = "*" unless $patterns;

    $me->{CMND} = "fetch";
    $me->command("XPAT $header $list $patterns");
}

# Fetch overview for range of articles.
sub xover {
    my $me = shift;
    my $list = shift || 1;
    my $last = shift;

    $list = "$list-$last" if $last;

    $me->{CMND} = "fetch";
    $me->command("XOVER $list");
}

# Fetch thread file.
sub xthread {
    my $me = shift;
    my $file = @_ ? "dbinit" : "thread";

    $me->{CMND} = "fetchbinary";
    $me->command("XTHREAD $file");
}

# Fetch index
sub xindex {
    my $me = shift;
    my $group = shift || $me->{GROUP} || "";

    $me->{CMND} = "fetch";
    $me->command("XINDEX $group");
}

# Search???  Expects search criteria, format unknown.
sub xsearch {
    my $me = shift;

    $me->command("XSEARCH") or return;

    $me->squirt(@_);
}

########################################################################
# Subroutines to implement basic methods.
########################################################################

# Send a command.
sub cmd {
    my ($me, $cmd) = @_;
    local $\ = "\015\012";

    my $SOCK = $me->{SOCK};

    1 < $me->{DBUG} and warn "$SOCK command: $cmd\n";

    defined fileno $SOCK or
	carp "News::NNTPClient: $SOCK has been closed\n" and return;

    print $SOCK $cmd;
}

# Send a command and retrieve status.  The only reason for not doing
# all the work in cmd is so this method can be replaced in a subclass,
# and the subclass can call cmd to do the real work.
sub command {
    my $me = shift;

    $me->cmd(@_) or return;

    $me->response();
}

# Like message, but with okprint
sub msg {
    my $me = shift;

    $me->okprint() or return;

    $me->{MESG};
}

# Extract Group info from MESG.
sub groupinfo {
    my $me = shift;

    $me->{GROUP} = "";

    # est-articles first-article last-article group-name
    if ($me->okprint and $me->{MESG} =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\w+)/) {
	$me->{GROUP} = $4;
	return wantarray ? ($2, $3) : "$2-$3";
    }

    return;
}

# Extract Message-ID from MESG.
sub msgid {
    my $me = shift;

    $me->okprint() and $me->{MESG} =~ /(<[^>]+>)/ ? $1 : "";
}

# Fetch text from server until single dot.
sub fetch {
    my $me = shift;
    local $/ = "\012";         # Only use LF to account for possible missing CR
    local $_;

    return unless $me->okprint();

    my @lines;

    my $SOCK = $me->{SOCK};

    # Loop reading lines until we receive a line with a single period.
    while (<$SOCK>) {
	s/\015?\012$/$me->{EOL}/; # Change termination

	last if $_ eq ".$me->{EOL}";

	s/^\.\././;		# Fix up escaped dots.
	push @lines, $_;	# Save each line.
    }

    1 < $me->{DBUG} and	warn "$SOCK received ${\scalar @lines} lines\n";

    wantarray ? @lines : \@lines;
}

# Fetch binary data from server, terminated by: \r\n.\r\n   Used by xthread
sub fetchbinary {
    my $me = shift;
    local $/ = "\015\012.\015\012";
    local $_;

    return unless $me->okprint();

    my $SOCK = $me->{SOCK};

    my $data = <$SOCK>;

    chomp $data;

    1 < $me->{DBUG} and	warn "$SOCK received ${\length $data} bytes\n";

    $data;
}

# Figure out what we should return to sender
sub returnval {
    my $me = shift;

    my $command = $me->{CMND} || "okprint";

    $me->{CMND} = "";		# reset after use.

    $me->$command();
}

# Read response to some action (connect, command or squirt)
sub response {
    my $me = shift;
    local $/ = "\012";         # Only use LF to account for possible missing CR
    local $_;

    my $SOCK = $me->{SOCK};

    $_ = <$SOCK>;

    $me->{CODE} = 0;
    $me->{MESG} = "";

    defined ($_) or
	carp "News::NNTPClient unexpected EOF on $SOCK\n" and return;

    s/\015?\012$//;		# Remove termination

    if (/^((\d\d)(\d))\s*(.*)/) { # Split out numeric code and message.
	$me->{POST} = !$3 if $2 == 20;
	$me->{CODE} = $1;
	$me->{MESG} = $4;
    } else {
	warn "News::NNTPClient garbled response: $_\n";
	return;
    }

    1 < $me->{DBUG} and	warn "$SOCK result($me->{CODE}): $me->{MESG}\n";

    $me->returnval();
}

sub squirt {
    my $me = shift;
    local $\ = "\015\012";

    my $SOCK = $me->{SOCK};

    1 < $me->{DBUG} and warn "$SOCK sending ${\scalar @_} lines\n";

    foreach (@_) {
	local ($_) = $_;
	# Print each line, possibly prepending a dot for lines
	# starting with a dot and trimming any trailing \n.
	s/^\./../;
	s/\n$//;
	print $SOCK $_;
    }

    print $SOCK ".";	# Terminate message.

    1 < $me->{DBUG} and warn "$SOCK done sending\n";

    $me->response();
}

# Return time in YYYYMMDD HHMMSS format, for use with newnews and
# newgroups commands.  If passed a string already in that format, just
# return it.  Otherwise use localtime() to convert seconds to
# date/time.  Default is current time.
sub yymmdd_hhmmss {
    my $me = shift;
    my $time = shift || time();

    # Already in the correct format?
    return $time if $time =~ /^\d{8}\s+\d{6}(\s*GMT)?$/;

    # Check for old format.
    if ($time =~ /^\d{6}\s+\d{6}(\s*GMT)?$/) {
      carp "Short year in date, using anyway\n" if $me->{FDY};
      return $time;
    }

    # returns Seconds, Minutes, Hours, days, months - 1, years.
    my @t = ($me->{GMT} ? gmtime($time) : localtime($time))[0..5];

    $t[4]++;			# Fix up month
    if ($me->{FDY}) {
      $t[5] += 1900;		# Fix up year for 4 digit year.
    } else {
      $t[5] %= 100;		# Fix up year for 2 digit year.
    }
    my $fmt = "%.02d" x 3;
    sprintf "$fmt $fmt%s", reverse(@t), $me->{GMT} ? " GMT" : "";
}

# Convert list of newsgroup prefixes to distribution list.  For
# example: comp news -> "".  Returns null string if passed
# an empty list.
sub distributions {
    @_ and "<" . join(",", @_) . ">" or "";
}

1;

__END__