Added test script.

diff --git a/Makefile b/Makefile
index 86cb338d546a725e457ac8b7ffc6790a3d5a38e0..5f4ae7e18b713feafb875ccab7a3b85f3ad74094 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -42,7 +42,12 @@ testserver:
        PERL5LIB=./Net-Server-NNTP/lib ./newsd conf_file=test.conf
 
 test:
+       -test -f newsd.pid && kill `cat newsd.pid`
+       rm -f news.log
+       PERL5LIB=./Net-Server-NNTP/lib ./newsd conf_file=test.conf
+       sleep 1
        prove t/*.t
+       -test -f newsd.pid && kill `cat newsd.pid`
 
 schema:
        (echo 'set role news;'; cat schema.sql) | $(PSQL) 

diff --git a/newsd b/newsd
index 2a93085f8a098f6d2b3a9a2f4e42f44a12caa431..a84a5a3f7f62166edba37d32b2a91c18dbc1058e 100755 (executable)
--- a/newsd
+++ b/newsd
@@ -5,4 +5,10 @@ use warnings;
 
 use Net::Server::NNTP::Postgres;
 
+use Carp;
+$SIG{ __DIE__ } = sub { Carp::confess( @_ ) };
+$SIG{ __WARN__ } = sub { Carp::cluck( @_ ) };
+
+$ENV{TZ} = 'UTC'; # for logging
+
 Net::Server::NNTP::Postgres->new()->run();

diff --git a/schema.sql b/schema.sql
index 826bc855f545cb53520425af0332c7dceff634d9..769f0e5e23ad44cdbd6a89196dcde43a99a4956c 100644 (file)
--- a/schema.sql
+++ b/schema.sql
@@ -330,11 +330,19 @@ begin
 
        begin
                -- TODO improve this regular expression
-               NEW.expires = regexp_replace(header_value(header, 'Expires'),E'\\([^\\)]*\\)', ' ')::timestamptz;
+               NEW.expires = regexp_replace(header_value(NEW.header, 'Expires'),E'\\([^\\)]*\\)', ' ')::timestamptz;
        exception
                when OTHERS then NEW.expires = NULL;
        end;
 
+       -- TODO if date is null?
+       begin
+               -- TODO improve this regular expression
+               NEW.date = regexp_replace(header_value(NEW.header, 'Date'),E'\\([^\\)]*\\)', ' ')::timestamptz;
+       exception
+               when OTHERS then NEW.date = NULL;
+       end;
+
        if NEW.header is null then
                raise exception 'null header b';
        end if;
@@ -363,13 +371,14 @@ create or replace function xpost_trigger() returns trigger as $$
 declare
        hiwater integer;
 begin
-       select high + 1 from newsgroups where newsgroup = NEW.newsgroup
-       for update into hiwater;
+       update newsgroups set high = high + 1
+               where newsgroup = NEW.newsgroup returning high into hiwater;
+
        NEW.number := hiwater;
-       update newsgroups set high = high + 1 where newsgroup = NEW.newsgroup;
        return NEW;
 end;
 $$ language 'plpgsql';
+
 create trigger highwater before insert on xpost
        for each row execute procedure xpost_trigger();
 

diff --git a/t/01_connectivity.t b/t/01_connectivity.t
new file mode 100644 (file)
index 0000000..81c05b2
--- /dev/null
+++ b/t/01_connectivity.t
@@ -0,0 +1,100 @@
+#!/usr/bin/perl
+
+use Test::More tests => 14; 
+
+BEGIN { use_ok('Net::Cmd') }
+BEGIN { use_ok('Net::NNTP') }
+
+my $c = Net::NNTP->new(Host => '127.0.0.1', Port => 20203, Reader => 0);
+
+ok(defined $c, 'connected to localhost');
+
+BAIL_OUT(q{can't connect to test server'}) unless $c;
+
+sub Net::NNTP::issue {
+       my ($c, @cmd) = @_;
+       $c->command(@cmd);
+       $c->response();
+       return $c->code();
+}
+
+sub Net::NNTP::test {
+       my ($c, $valid, @cmd) = @_;
+       $c->response();
+       ok(grep {$c->code == $_} @$valid, "valid response for @$cmd = @$valid");
+       return $c->code;
+}
+
+# 3977:5.1.1 initial greeting must be 200 201 400 502
+my @valid = (200, 201, 400, 502);
+my $greeting = $c->code;
+
+ok(grep {$c->code == $_} @valid, 'correct initial response from server');
+
+unless ($greeting == 200 or $greeting = 201) {
+       goto done;
+}
+
+$c->command('CAPABILITIES');
+$c->response();
+is($c->code, 101, 'correct response to capabilities');
+$c->read_until_dot() if ($c->code == 101);
+
+$c->command('capabilities');
+$c->response();
+is($c->code, 101, 'lower case capabilities ok');
+my $capabilities = $c->read_until_dot() if ($c->code == 101);
+
+my %cap = ();
+my $twice = 0;
+foreach my $line (@$capabilities) {
+       my ($capability, @arg) = split(/\s+/, $line);
+       if (exists($cap{$capability})) {
+               $twice = 1;
+       }
+       $cap{$cap} = \@arg;
+}
+
+ok($twice == 0, 'Capability listed twice (3977:5.2.2)');
+
+$capabilities->[0] =~ /(VERSION) (\d+)(\r?)(\n)/;
+
+is($1, 'VERSION', 'VERSION capability first');
+is($2, 2, 'Version 2 server');
+
+unless ($2==2) {
+       diag('can only test version 2 servers');
+       goto quit;
+}
+
+SKIP: {
+       skip 'Net::Cmd strips \r, skipping \r\n testing', 2;
+       is($3, "\r", 'Server terminated line with \r');
+       is($4, "\n", 'Server terminated line with \n');
+}
+
+is($c->issue('aninvalidcommand'), 500, 'responds with 500 to unknown command');
+
+SKIP: {
+       skip 'No LIST capability, skipping list tests', 1 unless $cap{'LIST'};
+       is($c->issue('list aninvalidlist'), 501, 'responds with 501 to unknown list');
+}
+
+# RFC 4644
+if ($cap{'STREAMING'}) {
+       # check mode stream
+}
+
+quit:
+
+$c->command('QUIT');
+$c->response;
+is($c->code, 205, 'correct response to quit');
+
+done:
+done_testing();
+exit 0;
+
+sub checkcmd {
+       my ($cmd, $args, $valid) = @_;
+}