chiark / gitweb /
cgi-fcgi-perl: wip, doc comment
[chiark-utils.git] / scripts / ChiarkNNTP.pm
1 #!/usr/bin/perl
2
3 # Originally by Simon Tatham
4 # Modified by Richard Kettlewell, Colin Watson, Ian Jackson
5 #
6 # Copyright -2011 Simon Tatham
7 # Copyright 2011 Richard Kettlewell
8 # Copyright 2011 Colin Watson
9 # Copyright 2011 Ian Jackson
10 #
11 # Permission is hereby granted, free of charge, to any person obtaining a
12 # copy of this software and associated documentation files (the "Software"),
13 # to deal in the Software without restriction, including without limitation
14 # the rights to use, copy, modify, merge, publish, distribute, sublicense,
15 # and/or sell copies of the Software, and to permit persons to whom the
16 # Software is furnished to do so, subject to the following conditions:
17 #
18 # The above copyright notice and this permission notice shall be included in
19 # all copies or substantial portions of the Software.
20 #
21 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
22 # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
23 # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
24 # SOFTWARE IN THE PUBLIC INTEREST, INC. BE LIABLE FOR ANY CLAIM, DAMAGES OR
25 # OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
26 # ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
27 # DEALINGS IN THE SOFTWARE.
28
29 use strict qw(subs);
30 use warnings;
31
32 require 5.002;
33 use Socket;
34 use FileHandle;
35
36
37 BEGIN {
38     use Exporter   ();
39     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
40
41     # set the version for version checking
42     $VERSION     = 1.00;
43
44     @ISA         = qw(Exporter);
45     @EXPORT      = qw(cnntp_connect);
46     %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
47     
48     @EXPORT_OK   = qw();
49 }
50 our @EXPORT_OK;
51
52 sub cnntp_connect ($) {
53     my ($verbose) = @_;
54
55     my $ns=$ENV{'NNTPSERVER'};
56     if (!defined $ns or !length $ns) {
57         $ns = `cat /etc/nntpserver`;
58         chomp($ns);
59     }
60     my $port = (getservbyname("nntp", "tcp"))[2];
61     $ns = inet_aton($ns);
62     my $proto = getprotobyname("tcp");
63     my $paddr = sockaddr_in($port, $ns);
64
65     my $sock = new IO::Handle;
66     socket($sock,PF_INET,SOCK_STREAM,$proto) or die "socket: $!";
67     connect($sock,$paddr) or die "connect: $!";
68
69     $sock->autoflush(1);
70
71     return bless { S => $sock, V => $verbose };
72 }
73
74 sub banner_reader ($) {
75     my ($c) = @_;
76     my ($code,$l) = $c->getline();
77     $code =~ /^2\d\d/ or die "no initial greeting from server\n";
78     $c->docmd("MODE READER");
79 }
80
81 sub disconnect ($) {
82     my ($c) = @_;
83     close $c->{S};
84 }
85
86 sub putline ($$) {
87     my ($c, $line) = @_;
88     my $s = $c->{S};
89     my $v = $c->{V};
90     print $v ">>> $line\n" if $v;
91     print $s "$line\r\n";
92 }
93
94 sub getline_raw ($) {
95     my ($c) = @_;
96     my $s = $c->{S};
97     my $l = <$s>;
98     return $l;
99 }
100
101 sub getline ($) {
102     my ($c) = @_;
103     my $v = $c->{V};
104     my $l = $c->getline_raw();
105     $l =~ s/[\r\n]*$//s;
106     my $code = substr($l,0,3);
107     print $v "<<< $l\n" if $v;
108     return ($code,$l);
109 }
110
111 sub docmd ($$;$) {
112     my ($c,$cmd,$nocheck) = @_;
113     my ($code,$l);
114     for my $n (0,1) {
115         $c->putline($cmd);
116         ($code,$l) = $c->getline();
117         if ($code eq "480") { $c->auth(); } else { last; }
118     }
119     if (!$nocheck) {
120         $code =~ /^2\d\d/ or die "failed on `$cmd':\n$l\n";
121     }
122     return ($code,$l);
123 }
124
125 sub auth ($) {
126     my ($c) = @_;
127     # Authentication.
128     return if $c->{Authed}++;
129     my $auth = $ENV{"NNTPAUTH"};
130     if (defined $auth) {
131         $c->putline("AUTHINFO GENERIC $auth");
132         pipe AUTHSTDIN, TOAUTH or die "unable to create pipes";
133         pipe FROMAUTH, AUTHSTDOUT or die "unable to create pipes";
134         flush STDOUT;
135         my $pid = fork;
136         if (!defined $pid) {
137             die "unable to fork for authentication helper";
138         } elsif ($pid == 0) {
139             # we are child
140             $c->{V} = undef if $c->{V} eq 'STDOUT';
141             $ENV{"NNTP_AUTH_FDS"} = "0.1";
142             open STDIN, "<&AUTHSTDIN";
143             open STDOUT, ">&AUTHSTDOUT";
144             close $c->{S};
145             exec $auth;
146             die $!;
147         }
148         # we are parent
149         close AUTHSTDIN;
150         close AUTHSTDOUT;
151         autoflush TOAUTH 1;
152         my ($code,$l) = $c->getline(); print TOAUTH "$l\n";
153         while (<FROMAUTH>) {
154             s/[\r\n]*$//s;
155             $c->putline($_);
156             ($code,$l) = $c->getline();
157             print TOAUTH "$l\n";
158         }
159         die "failed authentication\n" unless $? == 0;
160     }
161 }
162
163 1;