File Coverage

blib/lib/Net/NNTP/Proxy.pm
Criterion Covered Total %
statement 15 356 4.2
branch 0 198 0.0
condition 0 117 0.0
subroutine 5 53 9.4
pod 30 37 81.0
total 50 761 6.5


line stmt bran cond sub pod time code
1             $VERSION = '0.54';
2             package Net::NNTP::Proxy;
3             our $VERSION = '0.54';
4              
5             # -*- Perl -*-
6             ###############################################################################
7             # Written by Tim Skirvin
8             # Relies extensively on code from Net::NNTP, which was written and maintained
9             # by Graham Barr . Thanks.
10             #
11             # Copyright 2000-2002, Tim Skirvin. Redistribution terms are below.
12             ###############################################################################
13              
14              
15             =head1 NAME
16              
17             Net::NNTP::Proxy - a news server in perl
18              
19             =head1 SYNOPSIS
20              
21             use Net::NNTP::Proxy;
22             my $server = new Net::NNTP::Proxy || die "Couldn't start the server: $!\n";
23             $server->push(new Net::NNTP::Client);
24             $server->listen(9119);
25             my $client = $server->connect;
26              
27             See below for more functions.
28              
29             =head1 DESCRIPTION
30              
31             This package is a basic news server written in perl. It contains a list
32             of Net::NNTP::Client connections, and talks to all of these to get its
33             data; it then serves it back out to a port just like a regular news server.
34             It's also clean enough to run multiple-processes (and maybe even
35             multi-threaded, if I'm lucky.)
36              
37             newsproxy.pl is used to actually run this thing.
38              
39             =head1 METHODS
40              
41             =over 4
42              
43             =cut
44              
45 1     1   926 use strict;
  1         2  
  1         38  
46 1     1   968 use Socket;
  1         4997  
  1         762  
47 1     1   851 use Errno qw(EAGAIN);
  1         1644  
  1         131  
48 1     1   1206 use News::Article;
  1         25103  
  1         47  
49              
50 1     1   13 use vars qw($DEBUG $MAXCONN $CONNMESSAGE $PORT $NEWLINE);
  1         2  
  1         5364  
51              
52             ### Variables #################################################################
53             $DEBUG = 1; # Should debugging be on? 1 = yes, 0 = no.
54             $MAXCONN = 5; # Maximum number of connections in the queue.
55             $CONNMESSAGE = ""; # Message to send when connected.
56             ###############################################################################
57              
58             $PORT = 119; # Default news port
59             $NEWLINE = "\r\n"; # Newline string
60              
61             =head2 NETWORK AND FUNCTIONALITY
62              
63             These functions create the object and connect it to the network.
64              
65             =item new ( )
66              
67             Create a new server object. Doesn't actually bind to the port; you still
68             need to use C for that.
69              
70             =cut
71              
72             sub new {
73 0     0 1   my $class = shift;
74 0           my $object = {};
75 0           bless $object, $class;
76 0           $object->_init('port', shift);
77             }
78              
79             ### _init ( KEY, VALUE [...] )
80             # Do the work for new(). And clone(), if I decide to make one.
81             sub _init {
82 0     0     my ($self, %hash) = @_;
83              
84             # User-modified variables
85 0   0       $$self{'NEWSSERVERS'} = $hash{'newsservers'} || [];
86              
87             # Cached variables
88 0   0       $$self{'SERVER'} = $hash{'server'} || "";
89 0   0       $$self{'GROUP'} = $hash{'group'} || "";
90 0   0       $$self{'POINTER'} = $hash{'pointer'} || 0;
91 0   0       $$self{'ARTICLES'} = $hash{'articles'} || [];
92              
93             # Internal variables
94 0   0       $$self{'SOCKET'} = $hash{'socket'} || {};
95              
96 0           $self;
97             }
98              
99             =item openport ( [PORT] )
100              
101             Listens on C for a TCP connection.
102              
103             =cut
104              
105             sub openport {
106 0     0 1   my ($self, $port) = @_;
107 0   0       my $server = $self->_open_socket($port || 119);
108 0 0         $$self{'SOCKET'} = $server if $server;;
109 0 0         return $server ? $self : undef;
110             }
111              
112             =item closeport ()
113              
114             Stops listening for a TCP connection.
115              
116             =cut
117              
118             sub closeport {
119 0     0 1   my ($self, @rest) = @_;
120 0 0         $$self{'SOCKET'} ? close $$self{'SOCKET'}
121             : 0;
122             }
123              
124             =item connect ( FILEHANDLE )
125              
126             Connects to the given C. Returns the filehandle again.
127              
128             =cut
129              
130             sub connect {
131 0     0 1   my ($self, $fh) = @_;
132 0   0       my $server = $$self{'SOCKET'} || return undef;
133 0   0       $fh ||= \*CLIENT;
134 0           accept($fh, $server);
135 0           $fh;
136             }
137              
138             =item disconnect ( FILEHANDLE )
139              
140             Disconnects from C, closing it in the process.
141              
142             =cut
143              
144             sub disconnect {
145 0 0   0 1   my ($self, $fh) = @_; return undef unless $fh;
  0            
146 0 0         return undef unless defined fileno($fh);
147 0           close $fh;
148             }
149              
150             =item process ( FILEHANDLE, LINE )
151              
152             Process C, which was received from C, and call the
153             appropriate news function (which are all documented below). Returns
154              
155             =cut
156              
157             sub process {
158 0   0 0 1   my ($self, $fh, $line) = @_; $line ||= $_;
  0            
159 0           $line =~ s/^\s+|\s+$//g; # Trim leading/trailing whitespace
160 0           my ($command, @rest) = split('\s+', $line);
161 0           my @return;
162 0 0         if (lc $command eq 'authinfo') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
163 0           @return = "400 Not yet implemented";
164             # @return = $self->authinfo(@rest);
165             } elsif (lc $command eq 'article') { # Works
166             # @return = $self->article($rest[0]);
167 0           @return = $self->article($rest[0], 1, 1);
168             } elsif (lc $command eq 'body') { # Works - sortof
169 0           @return = $self->article($rest[0], 0, 1);
170             # @return = $self->body(@rest);
171             } elsif (lc $command eq 'date') { # Works
172 0           @return = $self->date;
173             } elsif (lc $command eq 'group') { # Works
174 0           @return = $self->group($rest[0]);
175             } elsif (lc $command eq 'head') { # Works - sortof
176 0           @return = $self->article($rest[0], 1, 0);
177             # @return = $self->head(@rest);
178             } elsif (lc $command eq 'help') {
179 0           @return = "400 Not yet implemented";
180             # @return = $self->help(@rest);
181             } elsif (lc $command eq 'ihave') {
182 0           @return = "400 Not yet implemented";
183             # @return = $self->ihave(@rest);
184             } elsif (lc $command eq 'last') { # Works
185 0           @return = $self->last();
186             } elsif (lc $command eq 'list') {
187 0           @return = $self->list(@rest);
188             } elsif (lc $command eq 'listgroup') { # Works
189 0           @return = $self->listgroup($rest[0]);
190             } elsif (lc $command eq 'mode') { # Works
191 0           @return = $self->mode(@rest);
192             } elsif (lc $command eq 'newgroups') {
193 0           @return = "400 Not yet implemented";
194             # @return = $self->newgroups(@rest);
195             } elsif (lc $command eq 'newnews') {
196 0           @return = "400 Not yet implemented";
197             # @return = $self->newnews(@rest);
198             } elsif (lc $command eq 'next') { # Works
199 0           @return = $self->next();
200             } elsif (lc $command eq 'post') { # Works mostly
201 0           @return = $self->post($fh);
202             } elsif (lc $command eq 'slave') {
203 0           @return = "400 Not yet implemented";
204             # @return = $self->slave(@rest);
205             } elsif (lc $command eq 'stat') { # Works
206 0           @return = $self->stat($rest[0]);
207             } elsif (lc $command eq 'xgtitle') {
208 0           @return = "400 Not yet implemented";
209             # @return = $self->xgtitle(@rest);
210             } elsif (lc $command eq 'xhdr') {
211             # @return = $self->xhdr(@rest);
212             } elsif (lc $command eq 'xover') { # Works, I think
213 0           @return = $self->xover(@rest);
214             } elsif (lc $command eq 'xpat') {
215 0           @return = "400 Not yet implemented";
216             # @return = $self->xpat(@rest);
217             } elsif (lc $command eq 'xpath') {
218 0           @return = "400 Not yet implemented";
219             # @return = $self->xpath(@rest);
220             } elsif (lc $command eq 'quit') { # Works
221 0           $self->quit($fh);
222 0           return undef;
223             } else { # Works
224 0           @return = $self->badcommand;
225             }
226 0           print $fh join ($NEWLINE, @return, '');
227 0           1;
228             }
229              
230             =head2 NEWS SERVERS
231              
232             These functions return and manipulate the list of news servers that the
233             object connects to and works with.
234              
235             =item newsservers ( )
236              
237             Returns a reference to an array containing the list of news servers that
238             can be accessed.
239              
240             =item push ( SERVER [, SERVER [, SERVER [...]]] )
241              
242             Adds C item onto the end of the list of news servers.
243              
244             =item pop ( )
245              
246             Removes the first item from the list of the news servers.
247              
248             =cut
249              
250 0     0 1   sub newsservers { shift->{'NEWSSERVERS'} }
251 0     0 1   sub push { CORE::push ( @{shift->{'NEWSSERVERS'}}, @_ ) }
  0            
252 0     0 1   sub pop { unshift @{shift->{'NEWSSERVERS'}} }
  0            
253              
254              
255             =head2 NEWS FUNCTIONS
256              
257             These functions implement news functionality. Return values are designed
258             to be written to a socket, which is taken care of by C. None
259             of this stuff is overly well documented; it follows the NNTP standards
260             well where possible, however.
261              
262             =item authinfo ( USER, PASS )
263              
264             Not yet implemented.
265              
266             =cut
267              
268 0     0 1   sub authinfo { }
269              
270             =item article ( ID [, HEAD, BODY] )
271              
272             Retrieve and return the article indicated by C. Looks through the
273             list of news servers in order; the first server to have the article
274             returns it.
275              
276             =cut
277              
278             sub article {
279 0   0 0 1   my ($self, $id, $head, $body) = @_; $id ||= "";
  0            
280 0 0 0       return undef unless ($head || $body);
281 0           my $article = $self->_article($id); # Helper function
282 0 0 0       if ($article && ref $article) { # We got the article.
    0          
283 0 0         my $ID = ($id =~ /^\d+$/) ? $id : 0;
284 0           my $messageid = $article->header('message-id');
285 0           my $code;
286             my @return;
287 0 0         if ($head) {
288 0 0         CORE::push @return, $body ? "220 $ID $messageid article"
289             : "221 $ID $messageid head"
290             } else {
291 0 0         CORE::push @return, "222 $ID $messageid body" if $body;
292             }
293              
294             # We need to reformat the lines from rawheaders, which may include
295             # newlines, for later reformatting
296 0 0         if ($head) {
297 0           my @headers = $article->rawheaders;
298 0           foreach (@headers) { CORE::push @return, split("\n", $_); }
  0            
299 0 0         CORE::push @return, "" if $body;
300             }
301              
302             # Fix a bug in Net::NNTP
303 0 0         if ($body) { map { s/^\./../o } @{$article->body} }
  0            
  0            
  0            
304 0 0         CORE::push @return, $article->body if $body;
305 0           CORE::push @return, ".";
306 0 0         wantarray ? @return : join($NEWLINE, @return);
307             } elsif ($article) { # Error message - return it
308 0           $article;
309             } else {
310 0           "420 No such article\n";
311             }
312             }
313              
314             =item body ( ID )
315              
316             As C, but just returns the body.
317              
318             =cut
319              
320 0     0 1   sub body { shift->article($_[0], 0, 1) }
321              
322             =item date ()
323              
324             Returns the current date from the server.
325              
326             =cut
327              
328             sub date {
329 0     0 1   my @localtime = gmtime;
330 0           sprintf("111 %04d%02d%02d%02d%02d%02d\n",
331             $localtime[5] + 1900, $localtime[4] + 1, $localtime[3] + 1,
332             $localtime[2], $localtime[1], $localtime[0]);
333             }
334              
335             =item group ( GROUP )
336              
337             Changes to the given C.
338              
339             =cut
340              
341             sub group {
342 0 0   0 1   my ($self, $group) = @_; return undef unless $group;
  0            
343 0           my ($newsgroup, $server) = $self->_group($group);
344 0 0 0       return $self->nosuchgroup($newsgroup) unless ($newsgroup && $server);
345 0           $$self{GROUP} = $newsgroup; $$self{SERVER} = $server;
  0            
346 0           my @list = $self->_listgroup($newsgroup, $server); my $count = scalar @list;
  0            
347 0 0 0       sprintf('211 %d %d %d %s', $count || 0, $list[0] || 0,
      0        
348             $count ? $list[$count - 1] : 0, $group);
349             }
350              
351             =item head ( ID )
352              
353             As C, but just returns the headers.
354              
355             =cut
356              
357 0     0 1   sub head { shift->article($_[0], 1, 0) }
358              
359             =item help ()
360              
361             Not yet implemented.
362              
363             =cut
364              
365 0     0 1   sub help () { }
366              
367             =item ihave ()
368              
369             Not yet implemented
370              
371             =cut
372              
373 0     0 1   sub ihave { }
374              
375             =item last ()
376              
377             Stats the previous message, if there is one. See C.
378              
379             =cut
380              
381             sub last {
382 0     0 1   my $self = shift;
383 0 0         if ($$self{POINTER} < 0) {
    0          
384 0           "422 No Previous Article";
385             } elsif ($$self{POINTER} == 0) {
386 0           $$self{POINTER}--; "422 No Previous Article";
  0            
387             } else {
388 0           $$self{POINTER}--; $self->stat();
  0            
389             }
390             }
391              
392             =item list ( TYPE ARGS )
393              
394             Lists off a certain value. Valid values are:
395              
396             active ( PATTERN )
397             active.times
398             newsgroups ( PATTERN )
399             overview.fmt (NOT YET IMPLEMENTED)
400              
401             =cut
402              
403             sub list {
404 0     0 1   my ($self, $type, @args) = @_;
405 0 0 0       if (lc $type eq 'active' || lc $type eq '') {
    0 0        
    0          
    0          
406 0           $self->_list_active(@args);
407             } elsif (lc $type eq 'active.times' || $type eq 'active_times') {
408 0           $self->_list_active_times(@args);
409             } elsif (lc $type eq 'overview.fmt') { # Tricky
410             } elsif (lc $type eq 'newsgroups') {
411 0           $self->_list_newsgroups(@args);
412             } else { # None of the supported lists -> bad command
413 0           $self->badcommand;
414             }
415             }
416              
417             =item listgroup ( GROUP )
418              
419             Loads up a given group, and gets a list of articles in it.
420              
421             =cut
422              
423             sub listgroup { # Works!
424 0     0 1   my ($self, $group) = @_;
425 0           my ($newsgroup, $server) = $self->_group($group);
426 0 0 0       return $self->nosuchgroup($group) unless ($newsgroup && $server);
427 0           $$self{GROUP} = $newsgroup; $$self{SERVER} = $server;
  0            
428 0           my @list = $self->_listgroup($group, $server); my $count = scalar @list;
  0            
429 0           return join("\n", "211 Article list follows", @list, ".");
430             }
431              
432             =item mode ( STRING )
433              
434             Sets the reader mode. At present, only 'reader' works.
435              
436             =cut
437              
438             sub mode { # Works!
439 0     0 1   my ($self, $mode) = @_;
440 0 0         return $self->badcommand unless lc $mode eq 'reader';
441 0   0       return "200 " . ($CONNMESSAGE || "Welcome to $0");
442             }
443              
444             =item newgroups ( GROUPS, DATE, TIME, [TZ] )
445              
446             Not yet implemented
447              
448             =cut
449              
450 0     0 1   sub newgroups { }
451              
452             # newnews newsgroups yyyymmdd hhmmss [GMT]
453              
454             =item newnews ( GROUPS, DATE, TIME, [TZ] )
455              
456             Not yet implemented
457              
458             =cut
459              
460 0     0 1   sub newnews { }
461             # next
462             sub next {
463 0     0 0   my $self = shift;
464 0 0         return $self->nogroupselect() unless (defined $$self{GROUP});
465 0 0         if ($$self{POINTER} >= scalar@{$$self{ARTICLES}} - 1) {
  0            
466 0           "421 No Next Article";
467 0           } else { $$self{POINTER}++; $self->stat; }
  0            
468             }
469             # post
470             sub post {
471 0 0   0 0   my ($self, $fh) = @_; return undef unless $fh;
  0            
472 0           print $fh "340 Send article to be posted\n";
473 0           my @lines;
474 0           while (defined (my $line = <$fh>)) {
475 0           $line =~ s/(\r?\n|\n?\r)$//g; # chomp wasn't working
476 0 0         last if $line =~ /^\.$/;
477 0           CORE::push @lines, $line;
478             }
479 0   0       my $article = News::Article->new(\@lines)
480             || return "441 Posting Failed (Article was Empty)";
481 0 0         $article->write(\*STDOUT) if $DEBUG;
482 0           $article->set_headers('newsgroups',
483             $self->_fix_groups($article->header('newsgroups')) );
484 0           $article->add_message_id; $article->add_date;
  0            
485 0           my $success = 0; my @problems;
  0            
486 0           foreach my $server (@{$self->newsservers}) {
  0            
487 0   0       my $nntp = $server->nntp || next;
488 0           my $name = $server->name;
489 0 0         next unless $server->postok;
490 0           local $@;
491 0           warn "Posting to $name\n";
492 0           eval { $article->post($nntp) } ;
  0            
493 0 0         if ($@) {
494 0           chomp $@;
495 0           warn "Error in posting to $name: $@\n";
496 0           CORE::push @problems, "$name: $@";
497             } else {
498 0           $success++;
499             }
500             }
501 0 0         $success ? "240 Article Posted to $success servers"
502             : "441 Was unable to post to any news servers - " . join(', ', @problems);
503             }
504              
505             =item slave ()
506              
507             Not yet implemented
508              
509             =cut
510              
511 0     0 1   sub slave () { }
512              
513             # stat [MessageID|Number]
514             sub stat {
515 0     0 0   my ($self, $id) = @_;
516 0 0         return $self->nogroupselect() unless (defined $$self{GROUP});
517 0           my ($number, $messageid) = $self->_stat($id);
518 0   0       $number ||= 0;
519              
520 0 0         if ($messageid) { return "223 $number $messageid"; }
  0 0          
521 0           elsif ($number) { return "423 No Such Article In Group"; }
522 0           else { return "430 No Such Article"; }
523             }
524              
525             =item xgtitle ( GROUP_PATTERN )
526              
527             Not yet implemented
528              
529             =cut
530              
531 0     0 1   sub xgtitle { }
532              
533             =item xhdr ( RANGE | ID )
534              
535             Not yet implemented
536              
537             =cut
538              
539 0     0 1   sub xhdr { }
540              
541             =item xover ( RANGE )
542              
543             Returns the overview information from the given C.
544              
545             =cut
546              
547             sub xover {
548 0     0 1   my ($self, $range) = @_;
549 0 0         return $self->nogroupselect() unless (defined $$self{GROUP});
550            
551 0   0       my $server = $$self{SERVER} || return undef;
552 0   0       my $hash = $server->xover($range) || return undef;
553 0           my @return = "224 overview data follows";
554 0           foreach (sort { $a <=> $b } keys %{$hash}) {
  0            
  0            
555 0           CORE::push @return, join("\t", $_, @{$$hash{$_}});
  0            
556             }
557 0           CORE::push @return, ".";
558            
559 0           join("\n", @return);
560             }
561              
562             =item xpat ( HEADER, RANGE | ID, PATTERN [, PATTERN [, PATTERN ]] )
563              
564             Not yet implemented
565              
566             =cut
567              
568 0     0 1   sub xpat { }
569              
570             =item xpath ( ID )
571              
572             Not yet implemented
573              
574             =cut
575              
576 0     0 1   sub xpath { }
577              
578             =item quit ( FILEHANDLE )
579              
580             Close C and quit.
581              
582             =cut
583              
584             sub quit {
585 0     0 1   my ($self, $fh) = @_;
586 0 0         return undef unless defined fileno($fh);
587 0           print $fh "205 Goodbye\n";
588 0           close $fh;
589             }
590              
591             # Error messages
592 0   0 0 0   sub nosuchgroup { my $group = shift || ""; return "411 No such group $group" }
  0            
593 0     0 0   sub badcommand { "500 Syntax Error or Unknown Command" }
594 0     0 0   sub nogroupselect { "512 No Group Selected" }
595 0     0 0   sub badarticlenumber { "423 Bad article number"; }
596              
597             ###############################################################################
598             ##### INTERNAL AND HELPER FUNCTIONS ###########################################
599             ###############################################################################
600              
601             ### DESTROY
602             # When the object goes away, make sure that disconnect() is called.
603 0     0     sub DESTROY { shift->disconnect() }
604              
605             ### _fix_groups ( LINE )
606             # Takes a Newsgroups: line, and takes out everything after the '@' in each
607             # group. This is important for translating back to the real world's groups.
608             # Hopefully this won't break PGPMoose and such too badly; I don't think they
609             # follow Newsgroups:...
610             sub _fix_groups {
611 0     0     my ($self, $line) = @_;
612 0   0       my @groups = split(',', $line || "");
613 0           map { s/^\s*(\S+)(@\S*)\s*$/$1/ } @groups;
  0            
614 0           join(',', @groups);
615             }
616              
617             ### _group ( GROUP )
618             # Loads GROUP from the appropriate server
619             sub _group {
620 0 0   0     my ($self, $group) = @_; return undef unless $group;
  0            
621 0 0         if ($group =~ /^(.*)@(.*)$/) { # Group we created
622 0           my $newsgroup = $1; my $servername = $2;
  0            
623 0           foreach my $server (@{$$self{NEWSSERVERS}}) {
  0            
624 0 0         next unless $server;
625 0           my $newsserver = $server->name;
626 0 0         return ($newsgroup, $server) if ($servername eq $newsserver);
627             }
628 0           return undef;
629             } else { # Group we're proxying
630 0           my $newsgroup = $group;
631             # Figure out which server has the first feed of this group.
632 0           foreach my $server (@{$$self{NEWSSERVERS}}) {
  0            
633 0 0 0       next unless ($server && $server->connected);
634 0 0         $server->group($newsgroup) ? return ($newsgroup, $server) : next;
635             }
636             }
637 0           return undef;
638             }
639              
640             ### _list_newsgroups ( [PATTERN] )
641             # Creates the newsgroups list out of the newsgroups values.
642             sub _list_newsgroups {
643 0     0     my ($self, $pattern) = @_;
644 0   0       $pattern ||= '*';
645 0           my @return = "215 Newsgroups Follow";
646 0           my %fullhash;
647 0           foreach (@{$$self{'NEWSSERVERS'}}) {
  0            
648 0           my $server = $_->server;
649 0           my $hash = $_->newsgroups($pattern);
650 0           foreach (keys %{$hash}) {
  0            
651 0   0       $fullhash{$_} ||= $$hash{$_};
652 0           CORE::push @return, "$_\@$server $$hash{$_}";
653             }
654             }
655 0           foreach (keys %fullhash) { CORE::push @return, "$_ $fullhash{$_}"; }
  0            
656 0           CORE::push @return, ".";
657 0 0         wantarray ? @return : join($NEWLINE, @return);
658             }
659              
660             ### _list_active ( [PATTERN] )
661             # Creates the active list out of the active values.
662             sub _list_active {
663 0     0     my ($self, $pattern) = @_;
664 0   0       $pattern ||= '*';
665 0           my @return = "215 Newsgroups Follow .";
666 0           my %fullhash;
667 0           foreach (@{$$self{'NEWSSERVERS'}}) {
  0            
668 0   0       my $name = $_->name || "";
669 0   0       my $hash = $_->active($pattern) || {};
670 0           foreach (sort keys %{$hash}) {
  0            
671 0 0         next unless $_;
672 0           CORE::push @return, "$_\@$name @{$$hash{$_}}";
  0            
673 0   0       $fullhash{$_} ||= "@{$$hash{$_}}";
  0            
674             }
675             }
676 0           foreach (sort keys %fullhash) { CORE::push @return, "$_ $fullhash{$_}"; }
  0            
677 0           CORE::push @return, ".";
678 0 0         wantarray ? @return : join($NEWLINE, @return);
679             }
680              
681             ### _list_active_times ( [PATTERN] )
682             # Creates the active.times list out of the active.times values.
683             sub _list_active_times {
684 0     0     my ($self, $pattern) = @_;
685 0   0       $pattern ||= '*';
686 0           my @return = "215 Group Creations";
687 0           my %fullhash;
688 0           foreach (@{$$self{'NEWSSERVERS'}}) {
  0            
689 0           my $server = $_->name;
690 0           my $hash = $_->active_times();
691 0           foreach (sort keys %{$hash}) {
  0            
692 0 0         next unless $_;
693 0           CORE::push @return, "$_\@$server @{$$hash{$_}}[0]";
  0            
694 0   0       $fullhash{$_} ||= "@{$$hash{$_}}[0]";
  0            
695             }
696             }
697 0           foreach (sort keys %fullhash) { CORE::push @return, "$_ $fullhash{$_}"; }
  0            
698 0           CORE::push @return, ".";
699 0 0         wantarray ? @return : join($NEWLINE, @return);
700             }
701              
702             ### _listgroup ( [GROUP] , SERVER )
703             # Returns the listgroup information. GROUP can be 'undef' if you'd like.
704             sub _listgroup {
705 0 0   0     my ($self, $group, $server) = @_; return undef unless $server;
  0            
706 0   0       $$self{ARTICLES} = $server->listgroup($group) || [];
707 0           $$self{POINTER} = 0;
708 0 0         wantarray ? @{$$self{ARTICLES}} : $$self{ARTICLES};
  0            
709             }
710              
711             ### _stat ( [ID] )
712             # Get the stat information on C, and set $POINTER if necessary.
713             sub _stat {
714 0     0     my ($self, $id) = @_;
715              
716             # Get the various important values for later use
717 0           my $pointer = $$self{POINTER}; my @articles = @{$$self{ARTICLES}};
  0            
  0            
718 0           my $server = $$self{SERVER}; my $group = $$self{GROUP};
  0            
719 0           my @servers = @{$$self{NEWSSERVERS}};
  0            
720            
721 0 0         if (!(defined $id)) { # No ID given at all -> last result
    0          
722 0 0         return (-1, undef) unless ($pointer >= 0);
723 0 0 0       if (defined $pointer && scalar @articles && defined $server) {
    0 0        
      0        
724             # my $nntp = $server->nntp || return (undef, undef);
725 0           my $messageid = $server->nntpstat($articles[$pointer]);
726 0 0         return ($articles[$pointer], $messageid) if $messageid;
727             } elsif (scalar @articles && defined $server) {
728 0           return (1, undef)
729             } else {
730 0           return (undef, undef);
731             }
732             } elsif ($id =~ /^\d+$/) { # Numeric ID -> in a group
733             # If we're not in a group, then just stop now.
734 0 0 0       return (undef, undef) unless ( scalar @articles && defined $server );
735             # There's two choices here - do it locally, or do it by the 'net. The
736             # latter is more computationally efficient but requires network accesses.
737 0           for (my $i = 0; $i < scalar @articles; $i++) {
738 0 0         if ($articles[$i] eq $id) {
739 0   0       my $messageid = $server->nntpstat($articles[$i]) || next;
740 0 0         $$self{POINTER} = $i if $messageid;
741 0 0         return ($id, $messageid) if $messageid;
742             }
743             }
744 0           $$self{POINTER} = undef;
745 0           return ($id, undef);
746             } else { # It's a full message ID
747 0           foreach ($server, @servers) {
748 0 0         next unless $_;
749 0           my $messageid = $_->nntpstat($id);
750 0 0         return (0, $messageid) if $messageid;
751             }
752 0           return (undef, undef);
753             }
754             }
755              
756             ### _article ( ID [, NID] )
757             # Downloads the given ID from all of the object's news servers.
758             sub _article {
759 0   0 0     my ($self, $id, $nid) = @_; $id ||= "";
  0            
760              
761             # If the given ID is numeric or not given, then try to find and
762             # load the appropriate message-ID. If that doesn't work, then it
763             # was a bad number.
764 0 0 0       if (!$id || $id =~ /^\d+$/) { # Non-existant or numeric
765 0           my ($number, $mid) = $self->_stat($id);
766 0 0 0       return "" if ($id && $mid && ($id eq $mid)); # TESTING
      0        
767 0           $self->_group($$self{GROUP});
768 0   0       return $self->_article( $mid, $id ) || $self->badarticlenumber;
769             }
770              
771 0 0         warn "Looking for article $id\n" if $DEBUG;
772            
773             # Search through all of the news servers in order for the full
774             # message-ID.
775 0           foreach my $server (@{$$self{NEWSSERVERS}}) {
  0            
776 0           my $article = News::Article->new($server->article($id));
777 0 0         return $article if $article;
778             }
779             # If all else fails, go with the numeric ID (if possible)
780 0   0       my $server = $$self{SERVER} || return undef;
781 0           my $article = News::Article->new($server->article($nid));
782 0 0         $article ? $article : undef;
783             }
784              
785             ### _open_socket ( PORT [, MAXCONN] )
786             # Build a socket. Code taken from Programming Perl, 3rd Edition.
787             sub _open_socket {
788 0     0     my ($self, $port, $maxconn) = @_;
789 0 0         return undef unless $port;
790            
791             # make the socket
792 0           socket(SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp'));
793            
794             # so we can restart our server quickly
795 0           setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1);
796            
797             # build up my socket address
798 0 0         unless (bind (SERVER, sockaddr_in($port, INADDR_ANY) ) ) {
799 0           warn "Couldn't bind to port $port: $!\n";
800 0           return undef;
801             }
802            
803             # establish a queue for incoming connections
804 0 0 0       unless (listen(SERVER, $maxconn || $MAXCONN || SOMAXCONN) ) {
805 0           warn "Couldn't listen on port $port: $!\n";
806 0           return undef;
807             }
808 0 0         warn "Listening on port $port\n" if $DEBUG;
809            
810 0           \*SERVER;
811             }
812              
813             =back
814              
815             =head1 REQUIREMENTS
816              
817             C, C
818              
819             =head1 NOTES
820              
821             This documentation is basically functional, but not much more.
822              
823             =head1 SEE ALSO
824              
825             L, L, L
826              
827             =head1 TODO
828              
829             Write better documentation. Write other news server types that aren't
830             Net::NNTP::Client. Implement the rest of the functions that I haven't
831             gotten around to yet. Speed it up.
832              
833             =head1 AUTHOR
834              
835             Written by Tim Skirvin .
836              
837             =head1 COPYRIGHT
838              
839             Copyright 2000-2002 by Tim Skirvin . This code may be
840             redistributed under the same terms as Perl itself.
841              
842             =cut
843              
844             1;
845              
846             # Version History
847             # v0.5a - Thu Nov 9 18:03:58 CST 2000
848             # Commenting in progress. This thing still needs some serious work to
849             # make it pretty, though.
850             # v0.51a - Tue Apr 24 15:56:49 CDT 2001
851             # Worked around a bug from Net::NNTP where '^..' is turned into '^.'.
852             # v0.52a - Mon Jan 28 11:30:32 CST 2002
853             # Replaced push() with CORE::push(). Started sorting the active and
854             # active_times() outputs. Changed to variable EOL string. Fixed some
855             # bugs in _list_active and the line with returning arrays.
856             # v0.53a - Wed Jan 30 09:32:27 CST 2002
857             # Fixed article() to have uniform newlines.
858             # v0.54 Thu Apr 22 11:44:01 CDT 2004
859             ### No real changes, just internal layout changes.