chiark / gitweb /
nntpid wip modulified
[chiark-utils.git] / scripts / ChiarkNNTP.pm
diff --git a/scripts/ChiarkNNTP.pm b/scripts/ChiarkNNTP.pm
new file mode 100644 (file)
index 0000000..5b69e28
--- /dev/null
@@ -0,0 +1,137 @@
+#!/usr/bin/perl
+
+use strict qw(subs);
+use warnings;
+
+require 5.002;
+use Socket;
+use FileHandle;
+
+
+BEGIN {
+    use Exporter   ();
+    our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+    # set the version for version checking
+    $VERSION     = 1.00;
+
+    @ISA         = qw(Exporter);
+    @EXPORT      = qw(cnntp_connect);
+    %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
+    
+    @EXPORT_OK   = qw();
+}
+our @EXPORT_OK;
+
+sub cnntp_connect ($) {
+    my ($verbose) = @_;
+
+    my $ns=$ENV{'NNTPSERVER'};
+    if (!defined $ns or !length $ns) {
+       $ns = `cat /etc/nntpserver`;
+       chomp($ns);
+    }
+    my $port = (getservbyname("nntp", "tcp"))[2];
+    $ns = inet_aton($ns);
+    my $proto = getprotobyname("tcp");
+    my $paddr = sockaddr_in($port, $ns);
+
+    my $sock = new IO::Handle;
+    socket($sock,PF_INET,SOCK_STREAM,$proto) or die "socket: $!";
+    connect($sock,$paddr) or die "connect: $!";
+
+    $sock->autoflush(1);
+
+    return bless { S => $sock, V => $verbose };
+}
+
+sub banner_reader ($) {
+    my ($c) = @_;
+    my ($code,$l) = $c->getline();
+    $code =~ /^2\d\d/ or die "no initial greeting from server\n";
+    $c->docmd("MODE READER");
+}
+
+sub disconnect ($) {
+    my ($c) = @_;
+    close $c->{S};
+}
+
+sub putline ($$) {
+    my ($c, $line) = @_;
+    my $s = $c->{S};
+    my $v = $c->{V};
+    print $v ">>> $line\n" if $v;
+    print $s "$line\r\n";
+}
+
+sub getline_raw ($) {
+    my ($c) = @_;
+    my $s = $c->{S};
+    my $l = <$s>;
+    return $l;
+}
+
+sub getline ($) {
+    my ($c) = @_;
+    my $v = $c->{V};
+    my $l = $c->getline_raw();
+    $l =~ s/[\r\n]*$//s;
+    my $code = substr($l,0,3);
+    print $v "<<< $l\n" if $v;
+    return ($code,$l);
+}
+
+sub docmd ($$;$) {
+    my ($c,$cmd,$nocheck) = @_;
+    my ($code,$l);
+    for my $n (0,1) {
+       $c->putline($cmd);
+       ($code,$l) = $c->getline();
+       if ($code eq "480") { $c->auth(); } else { last; }
+    }
+    if (!$nocheck) {
+       $code =~ /^2\d\d/ or die "failed on `$cmd':\n$l\n";
+    }
+    return ($code,$l);
+}
+
+sub auth ($) {
+    my ($c) = @_;
+    # Authentication.
+    return if $c->{Authed}++;
+    my $auth = $ENV{"NNTPAUTH"};
+    if (defined $auth) {
+       $c->putline("AUTHINFO GENERIC $auth");
+       pipe AUTHSTDIN, TOAUTH or die "unable to create pipes";
+       pipe FROMAUTH, AUTHSTDOUT or die "unable to create pipes";
+       flush STDOUT;
+       my $pid = fork;
+       if (!defined $pid) {
+           die "unable to fork for authentication helper";
+       } elsif ($pid == 0) {
+           # we are child
+           $c->{V} = undef if $c->{V} eq 'STDOUT';
+           $ENV{"NNTP_AUTH_FDS"} = "0.1";
+           open STDIN, "<&AUTHSTDIN";
+           open STDOUT, ">&AUTHSTDOUT";
+           close $c->{S};
+           exec $auth;
+           die $!;
+       }
+       # we are parent
+       close AUTHSTDIN;
+       close AUTHSTDOUT;
+       autoflush TOAUTH 1;
+       my ($code,$l) = $c->getline(); print TOAUTH "$l\n";
+       while (<FROMAUTH>) {
+           s/[\r\n]*$//s;
+           $c->putline($_);
+           ($code,$l) = $c->getline();
+           print TOAUTH "$l\n";
+       }
+       die "failed authentication\n" unless $? == 0;
+    }
+}
+
+1;