chiark / gitweb /
xbatmon-simple: Saner build rune.
[chiark-utils.git] / scripts / ChiarkNNTP.pm
1 #!/usr/bin/perl
2
3 use strict qw(subs);
4 use warnings;
5
6 require 5.002;
7 use Socket;
8 use FileHandle;
9
10
11 BEGIN {
12     use Exporter   ();
13     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
14
15     # set the version for version checking
16     $VERSION     = 1.00;
17
18     @ISA         = qw(Exporter);
19     @EXPORT      = qw(cnntp_connect);
20     %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
21     
22     @EXPORT_OK   = qw();
23 }
24 our @EXPORT_OK;
25
26 sub cnntp_connect ($) {
27     my ($verbose) = @_;
28
29     my $ns=$ENV{'NNTPSERVER'};
30     if (!defined $ns or !length $ns) {
31         $ns = `cat /etc/nntpserver`;
32         chomp($ns);
33     }
34     my $port = (getservbyname("nntp", "tcp"))[2];
35     $ns = inet_aton($ns);
36     my $proto = getprotobyname("tcp");
37     my $paddr = sockaddr_in($port, $ns);
38
39     my $sock = new IO::Handle;
40     socket($sock,PF_INET,SOCK_STREAM,$proto) or die "socket: $!";
41     connect($sock,$paddr) or die "connect: $!";
42
43     $sock->autoflush(1);
44
45     return bless { S => $sock, V => $verbose };
46 }
47
48 sub banner_reader ($) {
49     my ($c) = @_;
50     my ($code,$l) = $c->getline();
51     $code =~ /^2\d\d/ or die "no initial greeting from server\n";
52     $c->docmd("MODE READER");
53 }
54
55 sub disconnect ($) {
56     my ($c) = @_;
57     close $c->{S};
58 }
59
60 sub putline ($$) {
61     my ($c, $line) = @_;
62     my $s = $c->{S};
63     my $v = $c->{V};
64     print $v ">>> $line\n" if $v;
65     print $s "$line\r\n";
66 }
67
68 sub getline_raw ($) {
69     my ($c) = @_;
70     my $s = $c->{S};
71     my $l = <$s>;
72     return $l;
73 }
74
75 sub getline ($) {
76     my ($c) = @_;
77     my $v = $c->{V};
78     my $l = $c->getline_raw();
79     $l =~ s/[\r\n]*$//s;
80     my $code = substr($l,0,3);
81     print $v "<<< $l\n" if $v;
82     return ($code,$l);
83 }
84
85 sub docmd ($$;$) {
86     my ($c,$cmd,$nocheck) = @_;
87     my ($code,$l);
88     for my $n (0,1) {
89         $c->putline($cmd);
90         ($code,$l) = $c->getline();
91         if ($code eq "480") { $c->auth(); } else { last; }
92     }
93     if (!$nocheck) {
94         $code =~ /^2\d\d/ or die "failed on `$cmd':\n$l\n";
95     }
96     return ($code,$l);
97 }
98
99 sub auth ($) {
100     my ($c) = @_;
101     # Authentication.
102     return if $c->{Authed}++;
103     my $auth = $ENV{"NNTPAUTH"};
104     if (defined $auth) {
105         $c->putline("AUTHINFO GENERIC $auth");
106         pipe AUTHSTDIN, TOAUTH or die "unable to create pipes";
107         pipe FROMAUTH, AUTHSTDOUT or die "unable to create pipes";
108         flush STDOUT;
109         my $pid = fork;
110         if (!defined $pid) {
111             die "unable to fork for authentication helper";
112         } elsif ($pid == 0) {
113             # we are child
114             $c->{V} = undef if $c->{V} eq 'STDOUT';
115             $ENV{"NNTP_AUTH_FDS"} = "0.1";
116             open STDIN, "<&AUTHSTDIN";
117             open STDOUT, ">&AUTHSTDOUT";
118             close $c->{S};
119             exec $auth;
120             die $!;
121         }
122         # we are parent
123         close AUTHSTDIN;
124         close AUTHSTDOUT;
125         autoflush TOAUTH 1;
126         my ($code,$l) = $c->getline(); print TOAUTH "$l\n";
127         while (<FROMAUTH>) {
128             s/[\r\n]*$//s;
129             $c->putline($_);
130             ($code,$l) = $c->getline();
131             print TOAUTH "$l\n";
132         }
133         die "failed authentication\n" unless $? == 0;
134     }
135 }
136
137 1;