]> pd.if.org Git - newsd/commitdiff
Added Perl module files.
authorNathan Wagner <nw@hydaspes.if.org>
Fri, 2 Dec 2011 02:45:43 +0000 (21:45 -0500)
committerNathan Wagner <nw@hydaspes.if.org>
Fri, 2 Dec 2011 02:45:43 +0000 (21:45 -0500)
Net-Server-NNTP/Changes [new file with mode: 0644]
Net-Server-NNTP/MANIFEST [new file with mode: 0644]
Net-Server-NNTP/Makefile.PL [new file with mode: 0644]
Net-Server-NNTP/README [new file with mode: 0644]
Net-Server-NNTP/lib/Net/Server/NNTP.pm [new file with mode: 0644]
Net-Server-NNTP/lib/Net/Server/NNTP/Postgres.pm [new file with mode: 0644]
Net-Server-NNTP/t/00-load.t [new file with mode: 0644]
Net-Server-NNTP/t/boilerplate.t [new file with mode: 0644]
Net-Server-NNTP/t/pod-coverage.t [new file with mode: 0644]
Net-Server-NNTP/t/pod.t [new file with mode: 0644]

diff --git a/Net-Server-NNTP/Changes b/Net-Server-NNTP/Changes
new file mode 100644 (file)
index 0000000..09cb65e
--- /dev/null
@@ -0,0 +1,5 @@
+Revision history for Net::Server::NNTP
+
+0.01    Date/time
+        First version, released on an unsuspecting world.
+
diff --git a/Net-Server-NNTP/MANIFEST b/Net-Server-NNTP/MANIFEST
new file mode 100644 (file)
index 0000000..d7fe4da
--- /dev/null
@@ -0,0 +1,9 @@
+Changes
+MANIFEST
+Makefile.PL
+README
+lib/Net/Server/NNTP.pm
+lib/Net/Server/NNTP/Postgres.pm
+t/00-load.t
+t/pod-coverage.t
+t/pod.t
diff --git a/Net-Server-NNTP/Makefile.PL b/Net-Server-NNTP/Makefile.PL
new file mode 100644 (file)
index 0000000..42927a9
--- /dev/null
@@ -0,0 +1,16 @@
+use strict;
+use warnings;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+    NAME                => 'Net::Server::NNTP',
+    AUTHOR              => 'Nathan Wagner <nw@hydaspes.if.org>',
+    VERSION_FROM        => 'lib/Net/Server/NNTP.pm',
+    ABSTRACT_FROM       => 'lib/Net/Server/NNTP.pm',
+    PL_FILES            => {},
+    PREREQ_PM => {
+        'Test::More' => 0,
+    },
+    dist                => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
+    clean               => { FILES => 'Net::Server::NNTP-*' },
+);
diff --git a/Net-Server-NNTP/README b/Net-Server-NNTP/README
new file mode 100644 (file)
index 0000000..c5fdb66
--- /dev/null
@@ -0,0 +1,51 @@
+Net::Server::NNTP
+
+The README is used to introduce the module and provide instructions on
+how to install the module, any machine dependencies it may have (for
+example C compilers and installed libraries) and any other information
+that should be provided before the module is installed.
+
+A README file is required for CPAN modules since CPAN extracts the README
+file from a module distribution so that people browsing the archive
+can use it to get an idea of the module's uses. It is usually a good idea
+to provide version information here so that people can decide whether
+fixes for the module are worth downloading.
+
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+       perl Makefile.PL
+       make
+       make test
+       make install
+
+SUPPORT AND DOCUMENTATION
+
+After installing, you can find documentation for this module with the
+perldoc command.
+
+    perldoc Net::Server::NNTP
+
+You can also look for information at:
+
+    RT, CPAN's request tracker
+        http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net::Server::NNTP
+
+    AnnoCPAN, Annotated CPAN documentation
+        http://annocpan.org/dist/Net::Server::NNTP
+
+    CPAN Ratings
+        http://cpanratings.perl.org/d/Net::Server::NNTP
+
+    Search CPAN
+        http://search.cpan.org/dist/Net::Server::NNTP
+
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2010 Nathan Wagner
+
+This program is released under the following license: public domain
+
diff --git a/Net-Server-NNTP/lib/Net/Server/NNTP.pm b/Net-Server-NNTP/lib/Net/Server/NNTP.pm
new file mode 100644 (file)
index 0000000..63c37b0
--- /dev/null
@@ -0,0 +1,2043 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+
+use Date::Calc;
+use Socket;
+
+package Net::Server::NNTP;
+
+use base qw(Net::Server::Fork);
+
+=head1 NAME
+
+Net::Server::NNTP - The great new Net::Server::NNTP!
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION = '0.01';
+
+=head1 SYNOPSIS
+
+Quick summary of what the module does.
+
+This module implements NNTP.  It is intended to be compliant with RFCs
+3977, 5536, and 5537.
+
+By default, this module doesn't actually store any news articles.  It
+is intended that it will be sub-classed by a module that will implement
+all of the hook methods to store and retrieve articles.
+
+The networking services are handled by Net::Server, which this
+module sub-classes using the Net::Server::MultiType module.
+Therefore, the network configuration can be set with the options
+as listed in Net::Server.
+
+Net::Server data is in $server->{server}, as documented in the documentation
+for Net::Server.  This module puts all of its configuration data
+in $server->{nntp}.
+
+By default, the server will read F</etc/newsd.conf> at start-up for
+configuration options.
+
+The default Net::Server personality used is Fork, but that can be changed by
+setting the server_type configuration parameter (q.v.  Net::Server::MultiType).
+
+NNTP specific parameters are:
+
+ first_timeout specificies the timeout in seconds to receive an initial
+ command from the server.
+
+ timeout specifies the timeout in seconds for subsequent commands
+
+Perhaps a little code snippet.
+
+    use Net::Server::NNTP;
+
+    my $foo = Net::Server::NNTP->new();
+    ...
+
+=head1 EXPORT
+
+Nothing is exported.
+
+A list of functions that can be exported. You can delete this section if
+you don't export anything, such as for a purely object-oriented module.
+
+=cut 
+
+our $article_re = qr/\<[^\s\>]+\@[^\s\>]+\>/; # rfc 1036 2.1.5
+our $crlf = "\015\012"; # avoid local interpretation of \n
+
+=head1 NNTP FUNCTIONS
+
+=head1 STATE FUNCTIONS
+
+=head1 STORAGE FUNCTIONS
+
+=head1 INTERNAL FUNCTIONS
+
+=head1 Session Administration Commands
+
+These methods implement commands from section 5 of RFC 3977 and
+corresponding commands from other RFCs.
+
+=head2 greeting
+
+=head2 capabilities
+
+Handled internally by a coderef.  Returns the contents of %capabilities.
+
+=head2 mode
+
+Handles 'mode reader' (RFC 3977 5.3)
+
+=cut
+
+sub mode {
+       my ($s, $arg) = @_;
+       
+       return $s->response(501) unless @_ > 1;
+
+       if ($s->syntax($arg, '(?i)reader')) { # RFC 4644-2.3
+               return $s->response(200,undef,$s->pathhost);
+       }
+
+       if ($s->syntax($arg, '(?i)stream')) { # RFC 4644-2.3
+               return $s->response(203);
+       }
+
+       $s->response(501);
+       return;
+}
+
+=head2 quit
+
+=cut
+
+sub quit {
+       my ($s) = @_;
+       return $s->response(501, 'too many arguments') if @_ > 1;
+       $s->response(205);
+       die 'client quit';
+}
+
+=head2 server_quit
+
+       $s->server_quit($code, response);
+
+=cut
+
+sub server_quit {
+       my ($s, $code, @args) = @_;
+       $s->response($code, @args);
+       die 'server quitting';
+}
+
+=head1 Article Posting and Retrieval
+
+=head2 group
+
+       $s->group('news.software.nntp');
+
+Implements RFC 3977 6.1.1
+
+=cut
+
+sub group {
+       my ($s, $g) = @_;
+       my @row;
+
+       return $s->response(501) unless @_ == 2;
+
+       if (my ($estimate, $low, $high, $group) = @row = $s->groupinfo($g)) {
+               $s->pointer(@row[3,1]);
+               $s->article_number(undef) unless $estimate;
+               $s->response(211,undef,@row);
+       } else {
+               $s->response(411);
+       }
+}
+
+=head2 parse_grouprange
+
+takes a range spec and gets a low and high, as against a given group
+
+returns an empty list if the range spec doesn't parse.  The highwater
+returned will be undef if the given group is invalid.
+
+=cut
+
+sub parse_grouprange {
+       my ($s, $range, $group, $lowwater, $highwater) = @_;
+       
+       (undef, $lowwater, $highwater) = $s->groupinfo($group);
+
+       return ($group, $lowwater, $highwater) if @_ == 1;
+
+       my ($low, $r, $high) = $range =~ /(\d+)(-)?(\d+)?/;
+       if (defined $high) {
+               return ($group, $low, $high);
+       } elsif (defined $r) {
+               return ($group, $low, $highwater);
+       } elsif (defined $low) {
+               return ($group, $low, $low);
+       }
+       return ();
+}
+
+=head2 listgroup
+
+=cut
+
+sub listgroup {
+       my ($s,$arg) = @_;
+
+       my ($g, $range, @extraargs) = split(/\s+/, $arg);
+       return $s->response(501) if @extraargs;
+       
+       $range = '1-' unless defined $range;
+       $g = $s->selected_group unless defined $g;
+       return $s->response(412) unless defined $g;
+
+       my @grouprange = $s->parse_grouprange($range, $g);
+       return $s->response(501) unless @grouprange;
+
+       my @gi = $s->changegroup($g) if @grouprange;
+       return $s->response(411) unless @gi;
+
+       my @articles = $s->fetch_grouplist(@grouprange);
+
+       $s->response(211, undef, @gi);
+       $s->sendresults(@articles,'.');
+}
+
+=head2 last
+
+=cut
+
+sub last {
+       my ($s) = @_;
+
+       return $s->response(501) if @_ > 1;
+
+       return $s->response(412) unless $s->selected_group;
+       return $s->response(420) unless $s->article_number;
+
+       my ($n,$id) = $s->prev_article();
+
+       if ($n) {
+               $s->article_number($n);
+               $s->response(223, undef, $n, $id);
+       } else {
+               $s->response(422);
+       }
+}
+
+=head2 next
+
+Implements NNTP next (RFC 3977 6.1.4).  Moves the article pointer to the next
+valid article.
+
+=over 4
+
+If the currently selected newsgroup is valid, the current article number MUST
+be set to the next article in that newsgroup (that is, the lowest existing
+article number greater than the current article number).  If successful, a
+response indicating the new current article number and the message-id of that
+article MUST be returned.  No article text is sent in response to this command.
+
+If the current article number is already the last article of the newsgroup, a
+421 response MUST be returned.  In all other aspects (apart, of course, from
+the lack of 422 response), this command is identical to the LAST command
+(Section 6.1.3).
+
+=back
+
+=cut
+
+sub next {
+       my ($s) = @_;
+
+       return $s->response(501,'too many arguments') if @_ > 1;
+
+       return $s->response(412) unless $s->selected_group;
+       return $s->response(420) unless $s->article_number;
+
+       my ($n,$id) = $s->next_article();
+
+       if ($n) {
+               $s->article_number($n);
+               $s->response(223, undef, $n, $id);
+       } else {
+               $s->response(421);
+       }
+}
+
+# rfc 3977 6.2.1
+
+=head2 article
+
+=cut
+
+sub article {
+       my ($s, @args) = @_;
+       my ($a, $g, $n, $id);
+       
+       if (($id) = $s->syntax("@args", "($article_re)")) {
+               ($a) = $s->fetch_article($id);
+               return $s->response(430) unless defined $a;
+               $n = 0;
+       } elsif (($n) = $s->syntax("@args", "(\\d+)")) {
+               $g = $s->selected_group;
+               return $s->response(412) unless defined $g;
+               $s->log(4, "fetching $g ($n)");
+               ($a, $id) = $s->fetch_article($g,$n);
+               return $s->response(423) unless defined $a;
+               $s->article_number($n);
+       } elsif (!@args) {
+               ($g, $n) = $s->pointer;
+               return $s->response(412) unless defined $g;
+               return $s->response(420) unless defined $n;
+               $s->log(4, "fetching ($g $n)");
+               ($a,$id) = $s->fetch_article($g,$n);
+               return $s->response(420) unless defined $a;
+       } else {
+               return $s->response(501);
+       }
+
+       $s->response(220,undef,$n,$id);
+       $s->print($a);
+}
+
+# rfc 3977 6.2.2
+=head2 head
+
+=cut
+
+sub head {
+       my ($s, @args) = @_;
+       my ($a, $g, $n, $id);
+       
+       if (($id) = ("@args" =~ "($article_re)")) {
+               ($a) = $s->fetch_head($id);
+               return $s->response(430) unless defined $a;
+               $n = 0;
+       } elsif (($n) = $s->matches("@args", "(\\d+)")) {
+               $g = $s->selected_group;
+               return $s->response(412) unless defined $g;
+               $s->log(4, "fetching $g ($n)");
+               ($a, $id) = $s->fetch_head($g,$n);
+               return $s->response(423) unless defined $a;
+               $s->article_number($n);
+       } elsif (!@args) {
+               ($g, $n) = $s->pointer;
+               $s->log(4, "fetching ($g $n)");
+               return $s->response(412) unless defined $g;
+               return $s->response(420) unless defined $n;
+               ($a, $id) = $s->fetch_head($g,$n);
+               return $s->response(420) unless defined $a;
+       } else {
+               return $s->response(501);
+       }
+
+       $s->response(221,undef,$n,$id);
+       $s->print($a);
+}
+
+# rfc 3977 6.2.3
+=head2 body
+
+=cut
+
+sub body {
+       my ($s, @args) = @_;
+       my ($a, $g, $n, $id);
+       
+       if (($id) = $s->syntax("@args", "($article_re)")) {
+               ($a) = $s->fetch_body($id);
+               return $s->response(430) unless defined $a;
+               $n = 0;
+       } elsif (($n) = $s->syntax("@args", "(\\d+)")) {
+               $g = $s->selected_group;
+               return $s->response(412) unless defined $g;
+               $s->log(4, "fetching $g ($n)");
+               ($a, $id) = $s->fetch_body($g,$n);
+               return $s->response(423) unless defined $a;
+               $s->article_number($n);
+       } elsif (!@args) {
+               ($g, $n) = $s->pointer;
+               $s->log(4, "fetching ($g $n)");
+               return $s->response(412) unless defined $g;
+               return $s->response(420) unless defined $n;
+               ($a,$id) = $s->fetch_body($g,$n);
+               return $s->response(420) unless defined $a;
+       } else {
+               return $s->response(501);
+       }
+
+       $s->response(222,undef,$n,$id);
+       $s->print($a);
+}
+
+# rfc 3977 6.2.4
+=head2 stat
+
+=cut
+
+sub stat {
+       my ($s, @args) = @_;
+       my ($a, $g, $n, $id);
+       
+       if (($id) = $s->syntax("@args", "($article_re)")) {
+               $id = $s->fetch_stat($id);
+               return $s->response(430) unless defined $id;
+               $n = 0;
+       } elsif (($n) = $s->syntax("@args", "(\\d+)")) {
+               $g = $s->selected_group;
+               return $s->response(412) unless defined $g;
+               $s->log(4, "fetching $g ($n)");
+               $id = $s->fetch_stat($g,$n);
+               return $s->response(423) unless defined $id;
+               $s->article_number($n);
+       } elsif (!@args) {
+               ($g, $n) = $s->pointer;
+               $s->log(4, "fetching ($g $n)");
+               return $s->response(412) unless defined $g;
+               return $s->response(420) unless defined $n;
+               $id = $s->fetch_stat($g,$n);
+               return $s->response(420) unless defined $id;
+       } else {
+               return $s->response(501);
+       }
+
+       $s->response(223,undef,$n,$id);
+}
+
+# rfc 3977 6.3.1
+# rfc 5537 3.5
+
+=head2 post
+
+=cut
+
+sub post {
+       my ($s) = @_;
+       my $posted = 0;
+
+       # 5537-3.5-1 
+       return $s->response(440) unless $s->permit_posting;
+
+       my $rid = sprintf('<%s@%s>', Data::UUID->new()->create_str(),$s->pathhost);
+
+       $s->response(340, 'Ok, recommended ID %s', $rid);
+
+       my $a = $s->receive();
+       return $s->response(441) unless $a;
+
+       # 5537-3.5-2
+       if (!defined($a->header('From'))
+               or !defined($a->header('Newsgroups'))
+               or !defined($a->header('Subject'))
+               or defined($a->header('Injection-Info'))
+               or defined($a->header('Xref'))
+               or $a->header('Path') =~ /POSTED/
+               or !$s->valid_syntax($a)
+       ) {
+               # must reject 5537-3.5-2
+               return $s->response(441);
+       }
+
+       # TODO 5537-3.5-2 SHOULD reject any proto-article that contains a
+       # header field deprecated for Netnews
+       # TODO deprecated fields: 
+
+       # TODO policy reject NNTP-Posting-Host
+
+       # 5537-3.5-5
+       $a->ensure_header('Date', $s->system_ts());
+       $a->ensure_header('Message-ID', $rid);
+
+       #$a->ensure_header('Lines',$a->bodylines);
+
+       # 5537-3.5-8 5537-3.5-9
+       # store method will prepend the pathhost
+       $a->ensure_header('Path','not-for-mail');
+
+       # TODO 5537-3.5-10
+       $a->header('Injection-Info', sprintf(q{posting-host = "%s"},
+                       $s->{nntp}{peername}));
+
+       # TODO 5537-3.5-11
+
+       eval {
+               $posted = $s->store($a);
+       };
+       if ($@) {
+               return $s->response(441);
+       }
+       if ($posted) {
+               return $s->response(240,
+                       'article received ok, Message-ID %s', $a->messageid);
+       } else {
+               return $s->response(441);
+       }
+}
+
+=head2 ihave (RFC 3977 6.3.2)
+
+=cut
+
+sub ihave {
+       my ($s, $id) = @_;
+       my $ok = 0;
+
+       return $s->response(501) unless $id =~ /($article_re)/;
+       return $s->response(430) if $s->fetch_stat($id);
+       return $s->response(436) unless $s->permit_posting;
+
+       $s->response(335);
+
+       my $a = $s->receive();
+
+       return $s->response(436) unless $a;
+
+       eval {
+               $ok = $s->store($a);
+       };
+       if ($@) {
+               return $s->response(436);
+       }
+       $s->response($ok ? 235 : 437);
+}
+
+=head2 pointer
+
+=cut
+
+sub pointer {
+       my ($s, $g, $n) = (@_,undef,undef);
+
+       if (@_ > 1) {
+               $s->{nntp}{newsgroup} = $g;
+               $s->{nntp}{number} = $n;
+       }
+       return wantarray ? ($s->{nntp}{newsgroup},$s->{nntp}{number}) : $s->{nntp}{newsgroup};
+}
+
+sub selected_group {
+       my ($s, $g) = (@_, undef);
+       if (@_ > 1) {
+               $s->{nntp}{newsgroup} = $g;
+       }
+       return $s->{nntp}{newsgroup};
+}
+
+sub article_number {
+       my ($s, $n) = (@_, undef);
+       if (@_ > 1) {
+               $s->{nntp}{number} = $n;
+       }
+       return $s->{nntp}{number};
+}
+
+our %capabilities = (
+       READER  => '',
+       IHAVE   => '',
+       POST    => '',
+       NEWNEWS => '',
+       HDR     => '',
+       'OVER MSGID'    => '',
+       'LIST ACTIVE NEWSGROUPS OVERVIEW.FMT ACTIVE.TIMES HEADERS'      => '',
+       STREAMING       => '',
+);
+
+our %hdrs = (
+       Lines   => 'lines',
+       Subject => 'subject',
+       'Message-ID'    => 'msgid',
+       Date    => 'date',
+       From    => 'from',
+       References      => 'references',
+       Path    => 'path',
+       Newsgroups      => 'newsgroups',
+       ':bytes'        => 'bytes',
+       ':lines'        => 'actuallines',
+       'Xref'  => 'local article numbers',
+);
+our @over = qw(Subject From Date Message-ID References :bytes :lines Xref);
+
+our %cmd = ();
+
+=head2 servertime
+
+=cut
+
+sub servertime {
+       return sprintf('%04d%02d%02d%02d%02d%02d', Date::Calc::System_Clock());
+}
+
+our $keyword_re = '^[a-zA-Z][a-zA-Z0-9\.\-]{2}';
+
+%cmd = (
+       article => \&article, # reader 6.2.1
+       authinfo        => \&unsupported, # rfc 4643
+       starttls        => \&unsupported, # rfc 4642, IO::Socket::SSL->start
+       body    => \&body, # reader 6.2.3
+       check   => \&check, # rfc 4644 2.4
+       takethis        => \&takethis, # rfc 4644 2.5
+       capabilities    => sub { # mandatory 5.2
+               my ($s, $arg) = @_;
+               if (@_ > 1 && $arg !~ /^$keyword_re$/) {
+                       $s->response(501);
+                       return;
+               }
+               $s->response(101);
+               $s->sendresults('VERSION 2', keys %capabilities,'.');
+       },
+       date    => sub {  # reader 7.1
+               my ($s) = @_;
+               $s->response(111,undef, $s->servertime);
+       },
+       group   => \&group, # reader 6.1.1
+       hdr     => \&hdr, # hdr 8.5
+       xhdr    => \&unimplemented,
+       head    => \&head, # mandatory 6.2.2
+       help    => sub { # mandatory 7.2
+               my ($s) = @_;
+               $s->response(100);
+               $s->sendresults('The following commands are implemented',
+                       sort grep { $cmd{$_} != \&unimplemented
+                               && $cmd{$_} != \&unsupported}
+                       keys %cmd,'.');
+       }, 
+       ihave   => \&ihave, # ihave 6.3.2
+       'last'  => \&last, # reader 6.1.3
+       list    => \&list, # list 7.6.[13456], over 8.4
+       listgroup       => \&listgroup, # reader 6.1.2
+       mode    => \&mode, # mode-reader 5.3, 4644-2.3 mode stream
+       newgroups       => \&newgroups, # reader 7.3
+       newnews => \&newnews, # newnews 7.4
+       'next'  => \&next, # reader 6.1.4
+       over    => \&over, # over 8.3
+       xover   => \&over, # we hope this is the same as over (it is, but the overview.fmt listing is different)
+       post    => \&post, # post 6.3.1
+       quit    => \&quit,
+       'stat'  => \&stat, # mandatory 6.2.4
+       # slave is removed from the protocol
+       # slave => sub {my ($s) = @_; $peer_is_slave = 1; $s->response(202)},
+       'xadmin'        => \&xadmin,
+);
+
+=head2 changegroup
+
+=cut
+
+sub changegroup {
+       my ($s, $group) = @_;
+
+       return () unless $group;
+
+       my @row = $s->groupinfo($group);
+
+       if (@row) {
+               $s->pointer($group,$row[1]);
+               return @row;
+       }
+       return ();
+}
+
+=head2 print
+
+       $s->print(@args);
+
+       delegated to IO::Socket->print()
+
+=cut
+
+sub print {
+       my ($s, @args) = @_;
+       $s->{server}{client}->print(@args);
+}
+
+=head2 sendresults
+
+       $s->sendresults(@lines);
+
+Sends each element of @lines followed by a crlf pair.
+If an element of @lines is a reference, it is assumed to be
+an arrayref and the elements thereof are joined with a space
+and the resulting string is output.
+
+=cut
+
+sub sendresults {
+       my ($s, @lines) = @_;
+       $s->print(ref $_ ? join(' ', @$_) : $_, $crlf) for @lines;
+}
+
+# rfc 3977 7.4
+
+=head2 newnews
+
+=cut
+
+sub newnews {
+       my ($s, @args) = @_;
+
+       my ($wildmat, $date, $time);
+
+       return $s->response(501) unless ($wildmat, $date, $time) =
+               $s->syntax("@args", '(\S+)\s+(\\d{6}|\\d{8})\s+(\\d{6})(\s+GMT)?');
+
+       my $ts = $s->parsetime($date,$time);
+       return $s->response(501) unless defined $ts;
+
+       my $regex = $s->wildmat_to_regex($wildmat);
+       return $s->response(501) unless defined $regex;
+
+       $s->log(2, "newnews wildmat = $regex");
+
+       my @article_ids = $s->fetch_newnews($ts, $regex);
+
+       $s->response(230);
+       $s->sendresults(@article_ids,'.');
+}
+
+=head2 list
+
+=cut
+
+sub list {
+       my ($s, $arg) = @_;
+       my ($subcmd, @args);
+       if (defined $arg) {
+               ($subcmd, @args) = split(/\s+/, $arg);
+       }
+       $subcmd = 'active' unless defined($subcmd); # 7.6.1.1
+       $subcmd = lc($subcmd);
+       my $q;
+       my @results;
+
+       if ($subcmd eq 'active') { # 7.6.3
+               if (@args <= 1) {
+                       @results = $s->fetch_active(@args);
+               } else {
+                       return $s->response(501);
+               }
+       }
+       elsif ($subcmd eq 'active.times') { # 7.6.4
+               if (@args <= 1) {
+                       @results = $s->fetch_activetimes(@args);
+                       return $s->response(503) unless ref $results[0];
+               } else {
+                       return $s->response(501);
+               }
+       }
+       # don't forget to update capabilities when this is implemented
+       elsif ($subcmd eq 'distrib.pats') { # 7.6.5
+               return $s->response(501) if @args;
+               return $s->response(503);
+               return;
+       }
+       elsif ($subcmd eq 'headers') { # 8.6
+               # TODO ask the storage what it can do
+               return $s->response(501) if @args;
+               @results = keys %hdrs;
+       }
+       elsif ($subcmd eq 'newsgroups') { # 7.6.6
+               if (@args <= 1) {
+                       @results = $s->fetch_activetimes(@args);
+                       return $s->response(503) unless ref $results[0];
+               } else {
+                       return $s->response(501);
+               }
+       }
+       elsif ($subcmd eq 'overview.fmt') { # 8.4
+               return $s->response(501) if @args;
+               # TODO use old xover format if it seems warranted
+               @results = $s->fetch_overviewfmt();
+               $s->response(215,'Order of fields in overview database.');
+               $s->sendresults(@results,'.');
+               return;
+       } else {
+               $s->response(501);
+               return;
+       }
+       $s->response(215);
+       $s->sendresults(@results,'.');
+}
+
+# command prep and check
+# 'command' => {
+#      args    => 'max args' or [min,max]
+#      check   => [regexes to validate args against, if defined]
+#      fail    => what to do if it fails
+#      func    => command to pass args on to
+# }
+# sub command_check {
+#      my ($syntax, @args) = @_;
+# }
+
+# see rfc 3977 7.3.2 for description of format
+=head2 parsetime
+
+=cut
+
+sub parsetime {
+       my ($s,$date,$time) = @_;
+
+       my $ts;
+       if ($date =~ /^(\d\d)(\d\d)(\d\d)$/) {
+               my $curyear = (localtime)[5]+1900;
+               my $curcent = int ($curyear/100);
+               my $yic = $curyear % 100;
+               my $cent = $1 <= $yic ? $curcent : $curcent - 1;
+               $ts = sprintf('%02d%02d-%02d-%02d', $cent,$1,$2,$3);
+       } elsif ($date =~ /^(\d\d\d\d)(\d\d)(\d\d)$/) {
+               $ts = sprintf('%04d-%02d-%02d', $1,$2,$3);
+       } else {
+               return undef;
+       }
+       if ($time =~ /^(\d\d)(\d\d)(\d\d)$/) {
+               $ts = sprintf('%s %02d:%02d:%02d',$ts,$1,$2,$3);
+       } else {
+               return undef;
+       }
+       return $ts;
+}
+
+
+=head2 wildmat_to_re
+
+=cut
+
+sub wildmat_to_re {
+        my ($wildmat) = @_;
+
+        $wildmat =~ s/\./\\\./g;
+        $wildmat =~ s/\?/\./g;
+        $wildmat =~ s/\*/\.\*/g;
+        return $wildmat;
+}
+
+=head2 wildmat_to_regex
+
+=cut
+
+sub wildmat_to_regex {
+        my ($s, $wildmat) = @_;
+
+        my @pats = split(/,/,$wildmat); # TODO look for escaped commas
+
+        my $sql = '';
+        # TODO special case '*' since it always matches
+
+        while ($pats[0] =~ /^!/) { shift @pats } # init neg can't match
+
+       my $negated;
+        foreach (@pats) {
+                $negated = s/^!//;
+                my $like = wildmat_to_re($_);
+               if (!$negated) {
+                       $sql .= '|' . $like;
+               } else {
+                       $sql =~ s/^\|//;
+                       $sql = "(^(?!$like)($sql)\$)";
+               }
+        }
+       $sql =~ s/^\|//;
+       $sql = "^($sql)\$" unless $negated;
+        return $sql;
+}
+
+=head2 checkargs
+
+=cut
+
+sub checkargs {
+       my ($s, $args, @regex) = @_;
+       my @args = @$args;
+
+       for (0..$#regex) {
+               my $re = $regex[$_];
+               next unless defined $re;
+               if ($args[$_] !~ /$re/) {
+                       $s->log(2, "Argument invalid: $args[$_] !~ /$re/");
+                       return 0;
+               }
+       }
+       return 1;
+}
+
+=head2 syntax
+
+Checks a string against a regex and returns the matches.
+Logs if the syntax fails.
+
+=cut
+
+sub syntax {
+       my ($s, $cmd, $re) = @_;
+       my @match;
+       
+       if (@match = ($cmd =~ /^$re$/)) {
+               return @match;
+       }
+
+       $s->log(3, "syntax fail: '$cmd' !~ /$re/");
+       return ();
+}
+
+=head2 matches
+
+Checks a string against a regex and returns the matches.
+
+=cut
+
+sub matches {
+       my ($s, $cmd, $re) = @_;
+       my @match;
+       
+       if (@match = ($cmd =~ /^$re$/)) {
+               return @match;
+       }
+
+       return ();
+}
+
+=head2 newgroups
+
+=cut
+
+sub newgroups {
+       my ($s, @args) = @_;
+       my ($date, $time);
+
+       return $s->response(501) unless ($date, $time) =
+               $s->syntax("@args", '(\\d{6}|\\d{8}) (\\d{6})( GMT)?');
+
+       my $ts = $s->parsetime($date,$time);
+       return $s->response(501) unless defined $ts;
+
+       my @results = $s->fetch_newgroups($ts);
+
+       $s->response(231);
+       $s->sendresults(@results,'.');
+}
+
+# TODO access control?
+
+=head2 permit_posting
+
+=cut
+
+sub permit_posting {
+       return 1;
+}
+
+
+# rfc3977 8.3.2
+
+=head2 over
+
+Calls $s->fetch_overview
+
+=cut
+
+sub over {
+       my ($s, $arg, @extra) = @_;
+       my @headers;
+       my ($id, $lo, $range, $hi);
+
+       return $s->response(501) if @extra;
+
+       if (!$arg) {
+               # 3977-8.5.1 third form
+               return $s->response(412) unless defined $s->selected_group;
+               return $s->response(420) unless defined $s->article_number;
+               @headers = $s->fetch_overview($s->pointer);
+               return $s->response(420) unless @headers;
+               return $s->response(503) if $headers[0] == undef;
+       } elsif (($id) = $s->syntax($arg, "($article_re)")) {
+               # 3977-8.5.1 first form
+               @headers = $s->fetch_overview($id);
+               return $s->response(430) unless @headers;
+               return $s->response(503) if $headers[0] == undef;
+       } elsif (($lo, $range, $hi) = $s->syntax($arg, '(\d+)(-)?(\d+)?')) {
+               # 3977-8.5.1 second form
+               return $s->response(423) if $hi < $lo;
+               return $s->response(412) unless defined $s->selected_group;
+               my @gi = $s->groupinfo();
+               return $s->response(412) unless @gi;
+               if (defined $hi) {
+                       @headers = $s->fetch_overview($gi[0], $lo, $hi);
+               } elsif (defined $range) {
+                       @headers = $s->fetch_overview($gi[0], $lo, $gi[2]);
+               } else {
+                       @headers = $s->fetch_overview($gi[0], $lo);
+               }
+               return $s->response(423) unless @headers;
+               return $s->response(503) if $headers[0] == undef;
+       } else {
+               return $s->response(501);
+       }
+
+       $s->response(225);
+       $s->sendresults(@headers, '.');
+}
+
+# rfc3977 8.6.2
+# TODO allow any header?
+
+=head2 hdr
+
+Implements 3977-8.5.1
+
+Calls $s->fetch_headers.
+
+=cut
+
+sub hdr {
+       my ($s, $args) = @_;
+
+       my ($field, $arg) = split(/\s+/, $args);
+       my ($id, $hi, $lo, $range);
+       my @headers;
+
+       if (!$arg) {
+               # 3977-8.5.1 third form
+               return $s->response(412) unless defined $s->selected_group;
+               return $s->response(420) unless defined $s->article_number;
+               @headers = $s->fetch_headers($field, $s->pointer);
+               return $s->response(420) unless @headers;
+               return $s->response(503) if $headers[0] == undef;
+       } elsif (($id) = $s->syntax($arg, "($article_re)")) {
+               # 3977-8.5.1 first form
+               @headers = $s->fetch_headers($field, $id);
+               return $s->response(430) unless @headers;
+               return $s->response(503) if $headers[0] == undef;
+       } elsif (($lo, $range, $hi) = $s->syntax($arg, '(\d+)(-)?(\d+)?')) {
+               # 3977-8.5.1 second form
+               return $s->response(423) if $hi < $lo;
+               return $s->response(412) unless defined $s->selected_group;
+               my @gi = $s->groupinfo();
+               return $s->response(412) unless @gi;
+               if (defined $hi) {
+                       @headers = $s->fetch_headers($field, $gi[0], $lo, $hi);
+               } elsif (defined $range) {
+                       @headers = $s->fetch_headers($field, $gi[0], $lo, $gi[2]);
+               } else {
+                       @headers = $s->fetch_headers($field, $gi[0], $lo);
+               }
+               return $s->response(423) unless @headers;
+               return $s->response(503) if $headers[0] == undef;
+       } else {
+               return $s->response(501);
+       }
+
+       foreach (@headers) {
+               $_->[1] =~ s/\r?\n//g;
+               $_->[1] =~ s/\t/ /g;
+       }
+
+       $s->response(225);
+       $s->sendresults(@headers, '.');
+}
+
+our %response = (
+       100     => 'help text follows',
+       101     => 'Capability list follows',
+       111     => '%s server date and time',
+
+       200     => 'server %s ready, posting allowed',
+       201     => 'server %s ready, posting prohibited',
+       202     => 'slave status noted',
+       203     => 'Streaming permitted',
+       205     => 'closing connection',
+       211     => '%d %d %d %s group selected',
+       215     => 'list of newsgroups follows',
+       220     => '%d %s article follows',
+       221     => '%d %s article headers follows',
+       222     => '%d %s article body follows',
+       223     => '%d %s article exists and selected',
+       224     => 'overview information follows',
+       225     => 'headers follow',
+       230     => 'list of new articles follows',
+       231     => 'list of new newsgroups follows',
+       235     => 'article transferred ok',
+       238     => '%s Send article to be transferred',
+       239     => '%s Article transferred OK',
+       240     => 'article received ok',
+
+       335     => 'send article to be transferred.  End with <CR-LF>.<CR-LF>',
+       340     => 'send article to be posted. End with <CR-LF>.<CR-LF>',
+
+       400     => 'service not available or no longer available',
+       401     => '%s server is in wrong mode; use indicated capability',
+       403     => 'internal fault preventing action being taken',
+       411     => 'no such newsgroup',
+       412     => 'no newsgroup selected',
+       420     => 'no current article has been selected',
+       421     => 'no next article in this group',
+       422     => 'no previous article in this group',
+       423     => 'no such article number in this group',
+       430     => 'no such article found',
+       431     => '%s Transfer not possible; try again later',
+       435     => 'article not wanted - do not send it',
+       436     => 'transfer failed - try again later',
+       437     => 'article rejected - do not try again',
+       438     => '%s Article not wanted',
+       439     => '%s Transfer rejected; do not retry',
+       440     => 'posting not allowed',
+       441     => 'posting failed',
+
+       500     => 'command not recognized',
+       501     => 'command syntax error',
+       502     => 'access restriction or permission denied',
+       503     => 'program fault - command not performed',
+);
+
+=head2 connect_to_storage
+
+=cut
+
+sub connect_to_storage {
+       my ($s) = @_;
+       
+       return $s->{db} if defined $s->{db};
+
+       # TODO use a config parameter optionally here
+       my $dsn = $ENV{'DBI_DSN'};
+       $dsn = 'dbi:Pg:dbname=news' unless defined $dsn;
+       $s->log(4, "connecting to $dsn");
+
+       $s->{db} = DBI->connect($dsn,'','',{AutoCommit => 0,RaiseError=>1});
+       $s->{db}->{PrintError} = 0;
+
+       $s->{db}->do("set CLIENT_ENCODING to 'SQL_ASCII'");
+
+       return;
+}
+
+=head2 Storage Access Functions
+
+=cut
+
+=head3 next($group)
+
+Return the next article number in a group, undef if none.
+Should return the number in a scalar context, number, articleid in
+a list context.
+
+=cut
+
+=head2 log_stats
+
+=cut
+
+sub log_stats {
+       my ($s) = @_;
+
+       my ($rec, $ref, $rej, $postp) = 
+       (
+               $s->{nntp}{response}{239}
+               + $s->{nntp}{response}{235}
+               + $s->{nntp}{response}{240}, # received
+
+               $s->{nntp}{response}{435},  # refused
+
+               $s->{nntp}{response}{439}
+               + $s->{nntp}{response}{437}, # rejected
+
+               $s->{nntp}{response}{436},  # postponed
+       );
+
+       $s->log(2, sprintf('%s received %d, refused %d, rejected %d, postponed %d', $s->client, $rec, $ref, $rej, $postp));
+
+       $s->{nntp}{response}{$_} = 0 for keys %response;
+}
+
+=head2 clientfh
+
+=cut
+
+sub clientfh {
+       my ($s) = @_;
+       return $s->{server}{client};
+}
+
+=head2 client
+
+=cut
+
+sub client {
+       my ($s) = @_;
+       $s->{server}->{peeraddr} . ':' .$s->{server}->{peerport};
+}
+
+=head2 process_request
+
+=cut
+
+sub pre_fork_hook {
+       my ($s) = @_;
+
+       # we don't have the peeraddr set yet.
+       #$s->log(2, 'forking for connection from %s', $s->{server}{client});
+
+       return 1;
+}
+
+sub post_accept_hook {
+       my ($s) = @_;
+
+       # net server seems to log connections
+       #$s->log(2, 'accepted connection from %s', $s->{server}{peeraddr});
+
+       return 1;
+}
+
+sub request_denied_hook {
+       my ($s) = @_;
+
+       $s->log(2, 'denied connection from %s', $s->{server}{peeraddr});
+}
+
+sub process_request {
+       my ($s) = @_;
+       #$s->log(2,'%s: connected, log_level %d, server_type (%s)',$s->client, $s->{server}{log_level}, join(', ', @{$s->{server}{server_type}}));
+
+       $s->connect_to_storage();
+
+       $s->{nntp}{connecttime} = time;
+       $s->{nntp}{response}{$_} = 0 for keys %response;
+
+       my $peername = undef;
+       # five seconds max to do reverse lookup, otherwise skip it
+       # TODO i think Net::Server will do the reverse
+       eval {
+               local $SIG{ALRM} = sub { die "Timed Out!\n" };
+               alarm(5);
+               ($peername) = gethostbyaddr(Socket::inet_aton($s->{server}->{peeraddr}), Socket::AF_INET());
+       };
+       if ($@) {
+               $s->log(1, "Can't get peername for ".$s->{server}->{peeraddr} . ": $@");
+               $peername = $s->{server}->{peeraddr};
+       }
+       $s->{nntp}{peername} = $peername;
+
+       # parent will kill us with a term
+       $SIG{TERM} = sub { $s->log_stats();exit 0 };
+
+       eval {
+               local $SIG{ALRM} = sub { die "Timed Out!\n" };
+               alarm($s->{nntp}{first_timeout});
+               $s->response($s->permit_posting()?200:201,undef,$s->pathhost);
+               # TODO use a variable so subclassers can use not STDIN
+               while (<>) {
+                       alarm(0);
+                       s/\r?\n$//;
+                       $s->log(3, '%s -> %s', $s->client, $_);
+                       my ($cmd, @args) = split(/\s+/, $_, 2);
+                       # TODO enforce maximum length?
+                       $cmd = lc($cmd);
+                       if (exists($cmd{$cmd})) {
+                               $s->{command} = $cmd;
+                               $cmd{$cmd}->($s, @args);
+                       } else {
+                               $s->log(4, "command not recognized '%s'", $cmd);
+                               $s->response(500);
+                       }
+                       alarm($s->{nntp}{timeout});
+               }
+               alarm(0);
+       };
+       if ($@=~/timed out/i) {
+               $s->log(2, '%s: Timed Out.', $s->client);
+       } elsif ($@ =~ /client quit/) {
+               $s->log(2, '%s: client quit', $s->client);
+       } elsif (defined($@) && length($@)) {
+               $s->log(0, "$@\n");
+       }
+       $s->log(2, '%s: disconnecting', $s->client);
+       $s->log_stats();
+}
+
+=head2 default_values
+
+=cut
+
+sub default_values {
+       ### add a single value option
+       my $hn = Sys::Hostname::hostname();
+       my @v = split(/\./, $hn);
+       shift @v if @v > 2;
+       unshift @v, 'news';
+       $hn = join('.', @v);
+
+       return {
+               port => 119,
+               log_level => 2, # this is default I think
+               user => 'news',
+               group => 'news',
+               server_type     => [qw(Fork)],
+               setsid => 1,
+               background      => 1,
+               log_file        => 'Sys::Syslog',
+               pid_file        => '/var/run/news/newsd.pid',
+               syslog_facility => 'news',
+               syslog_ident    => 'newsd',
+               syslog_logopt   => 'pid',
+               conf_file       => -r '/etc/newsd.conf' ? '/etc/newsd.conf' : undef,
+               first_timeout   => 30, # seconds to receive first command
+               timeout         => 900, # subsequent commands 15 min
+               pathhost        => $hn,
+       };
+}
+
+# server  text, pathhost
+# groupsync 604800 == weekly, use undef for no sync, or no active file
+# activefile 
+# newsgroups 
+
+# localgroups     text default 'local.*',
+# groups          text default '*'
+
+# insert into configuration values ('localgroups','local.*');
+
+=head2 options
+
+=cut
+
+sub options {
+       my ($s, $oh) = @_;
+
+       $s->log(1, 'options called');
+       $s->{'nntp'} ||= {};
+
+       my $opt = $s->{'nntp'};
+
+       ### setup options in the parent classes
+       $s->SUPER::options($oh);
+       
+
+
+       $oh->{'pathhost'} ||= \ $opt->{'pathhost'};
+
+       $opt->{'activesync'} ||= 604800;
+       $oh->{'activesync'} ||= \ $opt->{'activesync'};
+
+       $opt->{'activefile'} ||= 'ftp://ftp.isc.org/pub/usenet/CONFIG/active.gz';
+       $oh->{'activefile'} ||= \ $opt->{'activefile'};
+
+       $opt->{'newsgroups'} ||= 'ftp://ftp.isc.org/pub/usenet/CONFIG/newsgroups.gz';
+       $oh->{'newsgroups'} ||= \ $opt->{'newsgroups'};
+
+       $opt->{'first_timeout'} ||= 120;
+       $oh->{'first_timeout'} ||= \$ opt->{'first_timeout'};
+
+       $opt->{'timeout'} ||= 900;
+       $oh->{'timeout'} ||= \ $opt->{'timeout'};
+
+       #$template->{'my_option'} = \ $prop->{'my_option'};
+       
+       ### add a multi value option
+       #$prop->{'an_arrayref_item'} ||= [];
+       #$template->{'an_arrayref_item'} = $prop->{'an_arrayref_item'};
+}
+
+=head2 log
+
+       $s->log($fmt, @args);
+
+Overrides the Net::Server log method and always treats the first
+argument as a format string.  We have to do this because Net::Server
+treats the arguments differently depending on whether syslog is used.
+Uses Perl's sprintf to do the formatting.
+
+=cut
+
+sub log {
+       my ($s, $lvl, $fmt, @args) = @_;
+       my $msg;
+       
+       if (@args) {
+               $msg = sprintf($fmt, @args);
+       } else {
+               $msg = $fmt;
+       }
+
+       $s->SUPER::log($lvl, $msg);
+}
+
+=head2 response
+
+=cut
+
+sub response {
+       my ($s, $code, $msg, @args) = @_;
+
+       if (!defined($msg) && exists($response{$code})) {
+               $msg = $response{$code};
+       } elsif (!defined($msg)) {
+               $s->log(1,"no message for response code $code");
+               $msg = '';
+       }
+       my $line = sprintf "$code $msg", @args;
+
+       $s->log(3,'%s <- %s', $s->client, $line);
+       $s->{nntp}{response}{$code}++;
+
+       $s->print($line,$crlf);
+       return $code;
+}
+
+=head2 unimplemented
+
+=cut
+
+sub unimplemented {
+       my ($s, @args) = @_;
+       
+       $s->log(2,'%s unimplemented command: %s', $s->client, join(' ', $s->{command}, @args));
+       $s->response(500);
+}
+
+=head2 unsupported
+
+=cut
+
+sub unsupported {
+       my ($s, @args) = @_;
+       
+       $s->log(2,'%s unsupported command: %s', $s->client, join(' ', @args));
+       $s->log(2,'%s caller = ', $s->client, caller);
+       $s->response(503);
+}
+
+# rfc 4644
+
+=head2 check
+
+=cut
+
+sub check {
+       my ($s, $id) = @_;
+       my ($have) = $s->fetch_stat($id);
+       if ($have) {
+               $s->response(438, undef, $id);
+               $s->log(3, 'already have article %s, rejecting', $have);
+       } elsif ($s->{nntp}{'throttled'}) { # TODO some way to enter this state
+               # TODO maybe a SIGUSR1
+               $s->response(431, undef, $id);
+       } else {
+               $s->response(238, undef, $id);
+       }
+}
+
+# rfc 4644 2.5
+
+=head2 takethis
+
+=cut
+
+sub takethis {
+       my ($s, $id) = @_;
+       my $ok = 0;
+
+       my $a = $s->receive();
+
+       return $s->response(501) unless $id =~ /($article_re)/;
+
+       if (!$a) {
+               return $s->server_quit(400,"error in receiving article $id, failed to read");
+       } elsif ($id ne $a->messageid()) {
+               my $rid = $a->messageid();
+               $s->log(1, "message id mismatch.  headers follow\n" . $a->{head});
+               return $s->server_quit(400,"error in receiving article '$id', id mis-match = '$rid'");
+       }
+       eval {
+               $ok = $s->store($a);
+       };
+       if ($@) {
+               # rfc 4644 2.5.2
+               $s->rollback();
+               return $s->server_quit(400,"error in storing article $id");
+       }
+       if ($ok) {
+               $s->response(239,undef,$id);
+       } else {
+               return $s->response(439,undef,$id);
+       }
+}
+
+=head2 system_ts
+
+       my $now = $s->system_ts();
+
+Generates an RFC 5536 3.1.1 and RFC 5322 3.3 compliant date string, uses
+GMT/UTC.  See L<"Date::Calc"/"Today_and_Now">
+
+=cut
+
+sub system_ts {
+       my ($y, $m, $d, $hr, $min, $sec) = Date::Calc::Today_and_Now(1);
+
+       return sprintf('%02d %s %04d %02d:%02d:%02d +0000', $d,
+               substr(Date::Calc::Month_to_Text($m),0,3),
+               $y, $hr, $min, $sec);
+}
+
+# TODO actually check against RFC 5536
+
+=head2 valid_syntax
+
+=cut
+
+sub valid_syntax {
+       my ($s, $a) = @_;
+
+       my @headerfields = $a->head;
+       my %counts;
+
+       foreach (@headerfields) {
+               my @headerlines = split(/\r?\n/, $_);
+               return 0 unless $headerlines[0] =~ /^(\S+):.*\S/;
+               $counts{lc($_)}++;
+               foreach my $hl (@headerlines) {
+                       return 0 unless $hl =~ /\S/;
+               }
+       }
+
+       for (@counts{qw|approved archive control distribution expires
+                       followup-to injection-date injection-info
+                       lines newsgroups organization path summary
+                       supersedes user-agent xref|}) {
+               return 0 if (defined && $_ > 1);
+       }
+
+       return 1;
+}
+
+=head2 pathhost
+
+=cut
+
+sub pathhost {
+       my ($s,$set) = @_;
+
+       if (@_ > 1) {
+               $s->{nntp}{pathhost} = $set;
+       }
+
+       return $s->{nntp}{pathhost};
+}
+
+=head2 read_until_dot
+
+=cut
+
+sub read_until_dot {
+       my ($s, $fh) = @_;
+       my $text = '';
+
+       # TODO figure out why we can't read from $s->{server}{client}
+       # different buffering?
+       while (my $line = <>) {
+               $s->log(5, $line);
+               last if $line =~ /^\.\r?\n/;
+               $text .= $line;
+       }
+       return $text;
+}
+
+=head2 readarticle
+
+=cut
+
+sub readarticle {
+       my ($s,$fh) = @_;
+       my $a = Net::Server::NNTP::Article->new;
+
+       my $c = $s->read_until_dot($fh);
+       
+       ($a->{head}, $a->{body}) = split(/\r?\n\r?\n/, $c, 2);
+       $a->{head} .= "\r\n";
+
+       # TODO check article for validity
+       return $a;
+}
+
+=head2 receive
+       
+       my $a = $s->receive();
+
+Receives an article in "wire" format (i.e. ending with a . on a line,
+and initial . doubled).  Adds a path header if there isn't one, and adds
+pathhost to the path header.
+
+=cut
+
+sub receive {
+       my ($s) = @_;
+       $s->log(5, 'Starting article receive');
+       my $a = $s->readarticle($s->{server}{client});
+       $s->log(5, 'Read article');
+       $s->log(1, 'unable to read article for receive()') unless $a;
+       return undef unless $a;
+
+       $s->log(5, "got article: head: " . $a->{head});
+       $s->log(6, "got article: body: " . $a->{body});
+
+       $a->ensure_header('Path','not-for-mail');
+       $a->add_to_path($s->pathhost);
+
+       return $a;
+}
+
+=head2 process_moderated
+
+=cut
+
+sub process_moderated {
+       my ($s, $a, $g) = @_;
+       
+       $s->junk($a);
+       return 0;
+}
+
+sub fetch_moderator {
+       my ($s, $g) = @_;
+       return undef;
+}
+
+sub validate_approved {
+       my ($s, $a) = @_;
+
+       return 1;
+}
+
+=head3 store
+
+store should store an article in the article database
+
+arguments are a hashref with a head and body
+
+return false if the article should be rejected, return true if the
+article was accepted, die if there is an error
+
+=cut
+
+=head2 store
+
+=cut
+
+# see RFC 5537-5.1
+sub process_control {
+       my ($s, $a) = @_;
+       $s->log(1, q{%s: ignoring control message '%s' (%s)}, $s->client,
+               $a->control, join(',',$a->newsgroups));
+       return 1;
+}
+
+sub store {
+       my ($s, $a) = @_;
+       return 0 unless $a;
+
+       my $id = $a->messageid;
+       return 0 if $s->fetch_stat($id);
+       
+       my @groups = $s->check_active($a->newsgroups);
+       $s->log(3, 'no newsgroups header or no valid groups: %s', $a->newsgroups) unless @groups;
+       return 0 unless @groups;
+
+       $s->log(3, 'Checking for control messages');
+       if (defined(my $cmsg = $a->control())) {
+               return $s->process_control($a);
+       }
+
+       $s->log(3, 'Checking for moderated groups');
+       if (my $modgroup = $s->moderated_group(@groups)) {
+               if (!defined($a->approved)) {
+                       return $s->process_moderated($a, $modgroup);
+               } elsif (!$s->validate_approved($a)) {
+                       $s->junk($a);
+                       return 0;
+               }
+       }
+
+       return $s->store_article($a);
+}
+
+package Net::Server::NNTP::Article;
+use Sys::Hostname qw();
+use Data::UUID;
+
+=head2 new
+
+=cut
+
+sub new {
+       my ($pkg) = shift; 
+       return bless {
+               head => undef,
+               body => undef,
+               lines   => undef,
+               size    => undef,
+               @_
+       }, $pkg;
+}
+
+=head2 head
+
+=cut
+
+sub head {
+       my ($a) = @_;
+       return wantarray ? split($a->{head}, /\r?\n(?!\s)/) : $a->{head};
+}
+
+=head2 body
+
+=cut
+
+sub body {
+       my ($a) = @_;
+       return wantarray ? split($a->{body}, /\r?\n(?!\s)/) : $a->{body};
+}
+
+=head2 raw
+
+=cut
+
+sub raw {
+       my ($a) = @_;
+       return $a->{head} . "\r\n", $a->{body};
+}
+
+=head2 bodylines
+
+=cut
+
+sub bodylines {
+       my ($a) = @_;
+       return $a->{body} =~ tr/\n/\n/;
+}
+
+=head2 headlines
+
+=cut
+
+sub headlines {
+       my ($a) = @_;
+       return $a->{head} =~ tr/\n/\n/;
+}
+
+=head2 size
+
+=cut
+
+sub size {
+       my ($a) = @_;
+       return length($a->{head}) + length($a->{body}) + 2;
+}
+
+=head2 writehead
+
+=cut
+
+sub writehead {
+       my ($a,$fh,@trailers) = @_;
+       print $fh $a-{head};
+       print $_ for @trailers;
+}
+
+=head2 writebody
+
+=cut
+
+sub writebody {
+       my ($a,$fh,@trailers) = @_;
+       print $fh $a-{body};
+       print $_ for @trailers;
+}
+
+=head2 write
+
+=cut
+
+sub write {
+       my ($a,$fh,@trailers) = @_;
+       print $fh $a->{head}, "\r\n", $a->{body};
+       print $_,"\r\n" for @trailers;
+}
+
+=head2 read_until_dot
+
+=cut
+
+sub read_until_dot {
+       my ($a, $fh) = @_;
+       my $text = '';
+
+       while (my $line = <$fh>) {
+               last if $line =~ /^\.\r?\n/;
+               $text .= $line;
+       }
+       return $text;
+}
+
+=head2 read
+
+=cut
+
+sub read {
+       my ($a,$fh) = @_;
+       $a = $a->new unless ref $a;
+
+       my $c = $a->read_until_dot($fh);
+       
+       ($a->{head}, $a->{body}) = split(/\r?\n\r?\n/, $c, 2);
+       $a->{head} .= "\r\n";
+
+       return $a;
+}
+
+=head2 headers
+
+=cut
+
+sub headers {
+       my ($a,@want);
+       return map { $a->header($_) } @want;
+}
+
+# looks like headers are case insensitive.  see rfc 2822
+=head2 header
+
+=cut
+
+sub header {
+        my ($a, $want, $set) = @_;
+        my $h = $a->{head};
+
+        if (@_ > 2) {
+                $set =~ s/\r?\n?$//;
+
+                if ($a->{head} =~ /^((?i)\Q$want\E)\s*:/msx) {
+                $a->{head}
+                  =~ s/^((?i)\Q$want\E)\s*:\s?(.+?)$ \r?\n(?!\s)/$1: $set\r\n/msx;
+                } else {
+                        $a->{head} .= "$want: $set\r\n";
+                }
+                return $set;
+        }
+
+        $a->{head}
+        =~ /^((?i)\Q$want\E)\s*:\s?(.+?)$ \r?\n(?!\s)/msx;
+
+        return undef unless defined $2;
+
+        $set = $2;
+        $set =~ s/\r?\n?$//;
+
+        return $set;
+}
+
+=head3 number(@groups) returns number from the Xref header
+
+=cut
+
+=head2 number
+
+=cut
+
+sub number {
+       my ($a,@groups) = @_;
+
+       my $xref = $a->header('Xref');
+       return unless defined($xref);
+       my %numbers = split /\S+|:/, $xref;
+       return @numbers{@groups};
+}
+
+=head2 ensure_header
+
+=cut
+
+sub ensure_header {
+       my ($a,$h,$c) = @_;
+
+       $a->header($h,$c) unless defined($a->header($h));
+       return $a->header($h);
+}
+
+# generate an RFC 5536 3.1.1 and RFC 5322 3.3 compliant date string
+=head2 system_ts
+
+=cut
+
+sub system_ts {
+       my ($y, $m, $d, $hr, $min, $sec) = Date::Calc::Today_and_Now(1);
+
+       return sprintf('%02d %s %04d %02d:%02d:%02d +0000', $d,
+               substr(Date::Calc::Month_to_Text($m),0,3),
+               $y, $hr, $min, $sec);
+               
+}
+
+=head2 generate_id
+
+=cut
+
+sub generate_id {
+       my ($a, $host) = @_;
+       $host ||= Sys::Hostname::hostname();
+       return '<'.Data::UUID->new()->create_str().'@'.$host.'>';
+}
+
+# see 5536
+our @required_headers = qw(From Date Newsgroups Subject Message-ID Path);
+our @opt_headers = qw(Approved Archive Control Distribution Expires
+Followup-To Injection-Date Injection-Info Organization References Summary
+Supersedes User-Agent Xref);
+
+=head2 messageid
+
+=cut
+
+sub messageid {
+       my ($a,@args) = @_;
+       $a->header('Message-ID',@args);
+}
+
+=head2 path
+
+=cut
+
+sub path {
+       my ($a,@args) = @_;
+       my $p = $a->header('Path',@args);
+       return wantarray ? split(/\!/,$p) : $p;
+}
+
+# TODO could do a bit less work here if a scalar is wanted
+
+=head2 newsgroups
+
+=cut
+
+sub newsgroups {
+       my ($a,@set) = @_;
+
+       if (@set) {
+               $a->header('Newsgroups',join(',',@set));
+       } else {
+               @set = split(/\s*,\s*/,$a->header('Newsgroups'));
+       }
+
+       return wantarray ? @set : join(',',@set);
+}
+
+# TODO make sure we ignore the RFC's requirements on approved headers
+# If you don't know why, then don't change this
+
+=head2 approved
+
+=cut
+
+sub approved {
+       my ($a,@app) = @_;
+       $a->header('Approved',@app);
+}
+
+=head2 control
+
+=cut
+
+sub control {
+       my ($a,@arg) = @_;
+       $a->header('Control',@arg);
+}
+
+=head2 add_to_path
+
+=cut
+
+sub add_to_path {
+       my ($a,$path) = @_;
+       $path = Sys::Hostname::hostname() unless defined($path);
+
+       $a->header('Path',"$path!". $a->header('Path'));
+}
+
+=head1 AUTHOR
+
+Nathan Wagner, C<< <nw at hydaspes.if.org> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-net-server-nntp
+at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net::Server::NNTP>.
+I will be notified, and then you'll automatically be notified of
+progress on your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+    perldoc Net::Server::NNTP
+
+
+You can also look for information at:
+
+=over 4
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net::Server::NNTP>
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/Net::Server::NNTP>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Net::Server::NNTP>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/Net::Server::NNTP>
+
+=back
+
+=head1 SEE ALSO
+
+       L<Net::Server>
+
+       L<Net::Server::MultiType>
+
+=head1 ACKNOWLEDGEMENTS
+
+Urs Janssen, maintainer of the tin newsreader, helped with this module by
+providing a series of prompt and detailed bug reports on the NNTP
+implementation.
+
+=head1 COPYRIGHT & LICENSE
+
+Written entirely from scratch by Nathan Wagner and released into the
+public domain.
+
+=cut
+
+1; # End of Net::Server::NNTP
+
+
+__END__
diff --git a/Net-Server-NNTP/lib/Net/Server/NNTP/Postgres.pm b/Net-Server-NNTP/lib/Net/Server/NNTP/Postgres.pm
new file mode 100644 (file)
index 0000000..13e1850
--- /dev/null
@@ -0,0 +1,659 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+package Net::Server::NNTP::Postgres;
+
+our $VERSION = '0.01';
+
+use base qw(Net::Server::NNTP);
+
+use DBI;
+
+=head1 NAME
+
+Net::Server::NNTP::Postgres - The great new Net::Server::NNTP::Postgres!
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+=head1 SYNOPSIS
+
+This module provides a storage mechanism for Net::Server::NNTP.
+
+    use Net::Server::NNTP::Postgres;
+
+    Net::Server::NNTP::Postgres->new()->run();
+
+=head1 FUNCTIONS
+
+=head2 next_article
+
+       my ($n, $id) = $s->next_article($group, $number);
+       my ($n, $id) = $s->next_article();
+
+Return the number and id of the next article after the given number
+in the given group.  Return an empty list if there is no such article
+or group.  Die if there is a storage error.
+
+If a group and a number are not both passed, both the group and the
+number will be taken from $s->pointer().
+
+=cut
+
+sub next_article {
+       my ($s, $group, $number) = @_;
+
+       die "invalid next_article() call" if @_ == 2;
+
+       ($group, $number) = $s->pointer() if @_ < 3;
+
+       my $q = $s->prepare('select number,article from xpost where newsgroup = ? and number > ? order by number limit 1');
+
+       $q->execute($s->pointer);
+       return $q->fetchrow_array();
+}
+
+sub prev_article {
+       my ($s, $group, $number) = @_;
+
+       die "invalid prev_article() call" if @_ == 2;
+
+       ($group, $number) = $s->pointer() if @_ < 3;
+
+       my $q = $s->prepare('select number,article from xpost where newsgroup = ? and number < ? order by number desc limit 1');
+
+       $q->execute($s->pointer);
+       return $q->fetchrow_array();
+}
+
+=head2 groupinfo
+
+       $s->groupinfo($group);
+       $s->groupinfo();
+
+Returns a list of information about either the supplied group or the
+current group.  Returns an empty list if the group is invalid.
+
+=cut
+
+sub groupinfo {
+       my ($s, $g) = (@_, $_[0]->selected_group);
+
+       return () unless $g;
+
+       my $q = $s->prepare(q{ select
+               coalesce(count(X.article),0) as count,
+               coalesce(min(X.number),N.low) as low,
+               coalesce(max(X.number),N.high) as high,
+               N.newsgroup from newsgroups N left outer join xpost X on
+               X.newsgroup = N.newsgroup where N.newsgroup = ? and N.active
+               group by N.newsgroup, N.low, N.high});
+
+       $q->execute($g);
+       return $q->fetchrow_array();
+}
+
+sub fetch {
+       my ($s, $byid, $bygn, @args) = @_;
+       my ($g, $n, $id);
+       my $sql;
+
+       if (@args == 0) {
+               @args  = $s->pointer;
+               $sql = $bygn;
+       } elsif (@args == 1) {
+               $sql = $byid;
+       } elsif (@args == 2) {
+               $sql = $bygn;
+       }
+
+       my $q = $s->prepare($sql);
+       $q->execute(@args);
+
+       return $q->fetchrow_array;
+}
+
+=head2 fetch_stat
+
+       my ($id, $n) = $s->fetch_stat($id);
+       my ($id, $n) = $s->fetch_stat($g, $n);
+
+Test to see if a given article exists.  Arguments may be either a message ID or
+a group and article number, or none, in which case the current article pointer
+is used.  Returns the message id if it exists, an empty list otherwise.  
+
+=cut
+
+sub fetch_stat {
+       my ($s, @args) = @_;
+       $s->fetch(
+               q{select id from articles where id = ?},
+               q{select A.id from xpost X left join articles A on A.id =
+               X.article where X.newsgroup = ? and X.number = ?},
+               @args
+       );
+}
+
+=head2 fetch_article
+
+       my ($id, $a) = $s->fetch_article($id);
+       my ($id, $a) = $s->fetch_article($g, $n);
+       my ($id, $a) = $s->fetch_article();
+
+Fetches a given article from storage.  Returns the article and message 
+id, or an empty list if the article doesn't exist.
+
+=cut
+
+sub fetch_article {
+       my ($s, @args) = @_;
+       $s->fetch(
+               q{select multiline(header || E'\r\n' || body), id from articles
+               where id = ?},
+               q{select multiline(A.header || E'\r\n' || A.body), A.id from
+               xpost X left join articles A on A.id = X.article where
+               X.newsgroup = ? and X.number = ?},
+               @args
+       );
+}
+
+=head2 fetch_head
+
+=cut
+
+sub fetch_head {
+       my ($s, @args) = @_;
+
+       $s->fetch(
+               q{select multiline(header), id from articles where id = ?},
+               q{select multiline(A.header), A.id from xpost X left
+               join articles A on A.id = X.article where X.newsgroup = ? and
+               X.number = ?},
+               @args
+       );
+}
+
+=head2 fetch_body
+
+=cut
+
+sub fetch_body {
+       my ($s, @args) = @_;
+
+       $s->fetch(
+               q{select multiline(body), id from articles where id = ?},
+               q{select multiline(A.body), A.id from xpost X left
+               join articles A on A.id = X.article where X.newsgroup = ? and
+               X.number = ?},
+               @args
+       );
+}
+
+=head2 query
+
+Takes a query and executes it with the named arguments.
+
+=cut
+
+sub query {
+       my ($s, $q, @args) = @_;
+       my $st;
+
+       unless (defined($q)) {
+               $s->log(1,"tried to call null query");
+               return;
+       }
+       if (exists($s->{postgres}{query}{$q})) {
+               $st = $s->{postgres}{query}{$q};
+       } else {
+               $st = $s->prepare($q);
+               $s->{postgres}{query}{$q} = $st;
+       }
+
+       $st->execute(@args);
+       return $st;
+}
+
+=head2 queryrow
+
+       my @row = $s->queryrow($sql, @args);
+
+Run a query and return the first row.
+
+=cut
+
+sub queryrow {
+       my ($s, $q, @args) = @_;
+
+       $s->query($q,@args)->fetchrow_array();
+}
+
+=head2 querycol
+
+       my @column = $s->querycol($sql, @args);
+
+Run a query and return all values in the first column as a list
+
+=cut
+
+sub querycol {
+       my ($s, $sql, @args) = @_;
+
+       my @col = ();
+
+       my $q = $s->query($sql, @args);
+
+       while (my @r = $q->fetchrow_array) {
+               push @col, $r[0];
+       }
+
+       return @col;
+}
+
+sub fetch_overviewfmt {
+       my ($s) = @_;
+       my $q = $s->prepare(q{select header || case when ord <= 5 then ':' when
+               ord <= 7 then '' else ':full' end from header_order order by
+               ord});
+       $q->execute();
+       return @{$q->fetchall_arrayref};
+}
+
+sub fetch_newsgroups {
+       my ($s, @re) = @_;
+       my $sql;
+
+       if (@_ == 2) {
+               $sql = 'select N.newsgroup, N.description from newsgroups N
+               where N.description is not null and N.newsgroup ~ ?';
+       } else {
+               $sql = 'select N.newsgroup, N.description from newsgroups N
+               where N.description is not null and N.newsgroup ~ ?';
+       }
+       my $q = $s->prepare($sql);
+       $q->execute(@re);
+       return @{$q->fetchall_arrayref};
+}
+
+sub fetch_activetimes {
+       my ($s, @re) = @_;
+       my $sql;
+
+       if (@_ == 2) {
+               $sql = "select N.newsgroup, extract(epoch from N.created),
+               N.creator from newsgroups N where N.created is not null and
+               N.creator is not null and active and newsgroup ~ ?";
+       } else {
+               $sql = "select N.newsgroup, extract(epoch from N.created),
+               N.creator from newsgroups N where N.created is not null and
+               N.creator is not null and active";
+       }
+       my $q = $s->prepare($sql);
+       $q->execute(@re);
+       return @{$q->fetchall_arrayref};
+}
+
+
+sub fetch_active {
+       my ($s, @re) = @_;
+       my $sql;
+
+       if (@_ == 2) {
+               $sql = 'select N.newsgroup, high, low, N.posting from
+               newsgroups N where newsgroup ~ ?';
+       } else {
+               $sql = 'select N.newsgroup, high, low, N.posting from
+               newsgroups N';
+       }
+       my $q = $s->prepare($sql);
+       $q->execute(@re);
+       return @{$q->fetchall_arrayref};
+}
+
+
+=head2 fetch_headers
+
+       my @hdrs = $s->fetch_headers($id);
+       my @hdrs = $s->fetch_headers($group, $n);
+       my @hdrs = $s->fetch_headers($group, $low, $high);
+       
+Fetches article headers from the database.  If fetching the header
+in this way is supported, the return value should be a list of arrayrefs,
+each containing two elements, the article number and the header content.
+If a message id is passed, the function may return 0 for the article
+number or it may determine the article number within the current group,
+if any.
+
+The caller is responsible for any content transformations it is interested
+in (e.g. crlf removal and tab replacement).
+
+If fetching the given header in the manner the method is called is not
+supported, the function should return a single element list containing
+undef.  I.e "return (undef)";
+
+=cut
+
+sub fetch_headers {
+       my ($s, @args) = @_;
+
+       my $sql;
+
+       if (@_ == 2) { # message id
+               $sql = 'select 0, value from headers((select header from
+               articles where id = ?)) where upper(header) = upper(?)';
+       } elsif (@_ == 3) { # group and article number
+               $sql = "select X.number,O.value from xpost X,overview O where
+               upper(O.header) = upper(?) and X.newsgroup = ? and O.article =
+               X.article and X.number = ?";
+       } elsif (@_ == 4) { # group and range
+               $sql = "select X.number,O.value from xpost X,overview O where
+               upper(O.header) = upper(?) and X.newsgroup = ? and O.article =
+               X.article and X.number >= ? and X.number <= ?";
+       } else {
+               die "invalid call to fetch_headers";
+       }
+       
+       my $q = $s->prepare($sql);
+       $q->execute(@args);
+       my @hdrs = @{$q->fetchall_arrayref};
+       @hdrs = (undef) unless @hdrs;
+       return @hdrs;
+}
+
+sub fetch_overview {
+       my ($s, @args) = @_;
+
+       my $sql;
+
+       if (@_ == 2) { # message id
+               $sql = q{select E'0\t' || O.overview from articleover O where
+               article = ?};
+       } elsif (@_ == 3) { # group and article number
+               $sql = q{select X.number || E'\t' || O.overview from xpost X
+               inner join articleover O on X.article = O.article and
+               X.newsgroup = ? where X.number = ?};
+       } elsif (@_ == 4) { # group and range
+               $sql = q{select X.number || E'\t' || O.overview from xpost X
+               inner join articleover O on X.article = O.article and
+               X.newsgroup = ? where X.number >= ? and X.number <= ? order by
+               X.number};
+       } else {
+               die "invalid call to fetch_headers";
+       }
+       
+       my $q = $s->prepare($sql);
+       $q->execute(@args);
+       my @hdrs = @{$q->fetchall_arrayref};
+       @hdrs = (undef) unless @hdrs;
+       return @hdrs;
+}
+
+sub log_stats {
+       my ($s, @args) = @_;
+
+       $s->log(1, 'no database connection') unless $s->{db};
+
+       my ($rec, $ref, $rej, $postp) = 
+       (
+               $s->{nntp}{response}{239}
+               + $s->{nntp}{response}{235}
+               + $s->{nntp}{response}{240}, # received
+
+               $s->{nntp}{response}{435},  # refused
+
+               $s->{nntp}{response}{439}
+               + $s->{nntp}{response}{437}, # rejected
+
+               $s->{nntp}{response}{436},  # postponed
+       );
+
+       if ($s->{db}) {
+               # first, we might have gotten here with an aborted txn
+               $s->commit;
+               $s->rollback;
+
+               my $stats = $s->prepare(q{insert into sessions (peer, addr, port, connected, closed, received, refused, rejected, postponed) values (?,?,?,timestamp with time zone 'epoch' + ? * INTERVAL '1 second',timestamp with time zone 'epoch' + ? * INTERVAL '1 second',?,?,?,?)});
+
+               $stats->execute($s->{nntp}{peername},
+                       $s->{server}->{peeraddr},
+                       $s->{server}->{peerport},
+                       $s->{nntp}{connecttime}, time,
+                       $rec, $ref, $rej, $postp);
+               $s->commit;
+       }
+
+       $s->SUPER::log_stats(@args);
+}
+
+=head2 handle_moderated
+
+=cut
+
+sub process_moderated {
+       my ($s, $a) = @_;
+       my $sql = 'insert into moderated_posts (id, article) values (?,?';
+       my $q = $s->prepare($sql);
+       $q->execute($a->id, $a->content);
+       return 1;
+}
+
+
+sub store_article {
+       my ($s, $a) = @_;
+
+       my $peer = ($a->path())[1]; # could be "not-for-mail"
+       my $id = $a->messageid;
+
+       eval {
+               my $q = $s->prepare(q{insert into articles (id,header,body,peer) values (?,?,?,?)});
+               $q->execute($id, $a->{head}, $a->{body}, $peer);
+               $s->commit;
+       };
+       if ($@) {
+               $s->rollback;
+               $s->log(0,"article insert failure: $id: $@");
+               return 0;
+       } else {
+               $s->log(3, '%s: received %s', $s->client, $id);
+               return 1;
+       }
+
+}
+
+=head2 rollback
+
+=cut
+
+sub rollback {
+       my ($s) = @_;
+
+       $s->{db}->rollback;
+}
+
+
+=head2 commit
+
+=cut
+
+sub commit {
+       my ($s) = @_;
+       $s->{db}->commit;
+}
+
+
+=head2 prepare
+
+=cut
+
+sub prepare {
+       my ($s, $sql) = @_;
+
+       if ($s->{sql}{$sql}) {
+               return $s->{sql}{$sql};
+       }
+
+       $s->{sql}{$sql} = $s->{db}->prepare($sql);
+}
+
+
+=head2 fetch_newgroups
+
+       my ($group, $low, $high, $posting)  = $s->fetch_newgroups($timestamp);
+
+Returns articles received since $timestamp, optionally in groups matching a
+regex.
+
+$timestamp will be passed as an ISO formatted timestamp string, e.g.
+'2010-01-08 19:33:44'
+
+=cut
+
+sub fetch_newgroups {
+       my ($s, @args) = @_;
+       my $sql = 'select N.newsgroup, low, high, N.posting from newsgroups N
+       where created > ? and created is not null';
+
+       my $q = $s->query($sql, @args);
+
+       return @{$q->fetchall_arrayref};
+
+}
+
+=head2 fetch_newnews
+
+       my @article_ids = $s->fetch_newnews($timestamp);
+       my @article_ids = $s->fetch_newnews($timestamp, $group_regex);
+
+Returns articles received since $timestamp, optionally
+in groups matching a regex.
+
+$timestamp will be passed as an ISO formatted timestamp string, e.g.
+'2010-01-08 19:33:44'
+
+=cut
+
+sub fetch_newnews {
+       my ($s, @args) = @_;
+       my $sql;
+
+       if (@args == 2) {
+               $sql = 'select distinct X.article from xpost X left join
+               articles A on A.id = X.article where A.received > ? and
+               X.newsgroup ~ ?';
+       } elsif (@args == 1) {
+               $sql = 'select distinct X.article from xpost X left join
+               articles A on A.id = X.article where A.received > ?';
+       } else {
+               return ();
+       }
+
+       $s->querycol($sql, @args);
+}
+
+
+=head2 fetch_grouplist
+
+       my @articlenumbers = $s->fetch_grouplist($g, $low, $high);
+
+Returns a list of article numbers in a given group and in the given range.
+
+=cut
+
+sub fetch_grouplist {
+       my ($s, $group, $low, $high) = @_;
+       my $sql = q{select number from xpost where newsgroup = ? and number >=
+       ? and number <= ? order by number};
+       return $s->querycol($sql, $group, $low, $high);
+}
+
+=head2 check_active
+
+       my @active = $s->check_active(@checkgroups);
+
+Given a list of newsgroups, returns a list of which are active.
+
+=cut
+
+sub check_active {
+       my ($s,@groups) = @_;
+       my $sql = q{select newsgroup from newsgroups where newsgroup = ? and
+       active};
+       
+       return grep { $s->queryrow($sql, $_) } @groups;
+}
+
+=head2 moderated_group
+
+       my @moderated = $s->moderated_group(@checkgroups);
+
+Given a list of newsgroups, returns a list of which are moderated.
+
+=cut
+
+sub moderated_group {
+       my ($s,@groups) = @_;
+       my $sql = q{select newsgroup from newsgroups where posting = 'm' and
+       newsgroup = ? and active};
+       
+       return grep { $s->queryrow($sql, $_) } @groups;
+}
+
+
+=head1 AUTHOR
+
+Nathan Wagner, C<< <nw at hydaspes.if.org> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-net-server-nntp-postgres at rt.cpan.org>, or through
+the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net::Server::NNTP>.  I will be notified, and then you'll
+automatically be notified of progress on your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+    perldoc Net::Server::NNTP
+
+
+You can also look for information at:
+
+=over 4
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net::Server::NNTP>
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/Net::Server::NNTP>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Net::Server::NNTP>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/Net::Server::NNTP>
+
+=back
+
+
+=head1 ACKNOWLEDGEMENTS
+
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2010 Nathan Wagner, all rights reserved.
+
+This program is released under the following license: public domain
+
+
+=cut
+
+1; # End of Net::Server::NNTP::Postgres
diff --git a/Net-Server-NNTP/t/00-load.t b/Net-Server-NNTP/t/00-load.t
new file mode 100644 (file)
index 0000000..f4050b3
--- /dev/null
@@ -0,0 +1,10 @@
+#!perl -T
+
+use Test::More tests => 2;
+
+BEGIN {
+       use_ok( 'Net::Server::NNTP' );
+       use_ok( 'Net::Server::NNTP::Postgres' );
+}
+
+diag( "Testing Net::Server::NNTP $Net::Server::NNTP::VERSION, Perl $], $^X" );
diff --git a/Net-Server-NNTP/t/boilerplate.t b/Net-Server-NNTP/t/boilerplate.t
new file mode 100644 (file)
index 0000000..804cc4a
--- /dev/null
@@ -0,0 +1,56 @@
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More tests => 4;
+
+sub not_in_file_ok {
+    my ($filename, %regex) = @_;
+    open( my $fh, '<', $filename )
+        or die "couldn't open $filename for reading: $!";
+
+    my %violated;
+
+    while (my $line = <$fh>) {
+        while (my ($desc, $regex) = each %regex) {
+            if ($line =~ $regex) {
+                push @{$violated{$desc}||=[]}, $.;
+            }
+        }
+    }
+
+    if (%violated) {
+        fail("$filename contains boilerplate text");
+        diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
+    } else {
+        pass("$filename contains no boilerplate text");
+    }
+}
+
+sub module_boilerplate_ok {
+    my ($module) = @_;
+    not_in_file_ok($module =>
+        'the great new $MODULENAME'   => qr/ - The great new /,
+        'boilerplate description'     => qr/Quick summary of what the module/,
+        'stub function definition'    => qr/function[12]/,
+    );
+}
+
+TODO: {
+  local $TODO = "Need to replace the boilerplate text";
+
+  not_in_file_ok(README =>
+    "The README is used..."       => qr/The README is used/,
+    "'version information here'"  => qr/to provide version information/,
+  );
+
+  not_in_file_ok(Changes =>
+    "placeholder date/time"       => qr(Date/time)
+  );
+
+  module_boilerplate_ok('lib/Net/Server/NNTP.pm');
+  module_boilerplate_ok('lib/Net/Server/NNTP/Postgres.pm');
+
+
+}
+
diff --git a/Net-Server-NNTP/t/pod-coverage.t b/Net-Server-NNTP/t/pod-coverage.t
new file mode 100644 (file)
index 0000000..fc40a57
--- /dev/null
@@ -0,0 +1,18 @@
+use strict;
+use warnings;
+use Test::More;
+
+# Ensure a recent version of Test::Pod::Coverage
+my $min_tpc = 1.08;
+eval "use Test::Pod::Coverage $min_tpc";
+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage"
+    if $@;
+
+# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
+# but older versions don't recognize some common documentation styles
+my $min_pc = 0.18;
+eval "use Pod::Coverage $min_pc";
+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage"
+    if $@;
+
+all_pod_coverage_ok();
diff --git a/Net-Server-NNTP/t/pod.t b/Net-Server-NNTP/t/pod.t
new file mode 100644 (file)
index 0000000..ee8b18a
--- /dev/null
@@ -0,0 +1,12 @@
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More;
+
+# Ensure a recent version of Test::Pod
+my $min_tp = 1.22;
+eval "use Test::Pod $min_tp";
+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
+
+all_pod_files_ok();