File Coverage

blib/lib/Net/NNTP.pm
Criterion Covered Total %
statement 103 348 29.6
branch 25 244 10.2
condition 8 157 5.1
subroutine 21 93 22.5
pod 44 44 100.0
total 201 886 22.6


line stmt bran cond sub pod time code
1             # Net::NNTP.pm
2             #
3             # Copyright (C) 1995-1997 Graham Barr. All rights reserved.
4             # Copyright (C) 2013-2016, 2020 Steve Hay. All rights reserved.
5             # This module is free software; you can redistribute it and/or modify it under
6             # the same terms as Perl itself, i.e. under the terms of either the GNU General
7             # Public License or the Artistic License, as specified in the F file.
8              
9             package Net::NNTP;
10              
11 6     6   375255 use 5.008001;
  6         60  
12              
13 6     6   31 use strict;
  6         10  
  6         121  
14 6     6   41 use warnings;
  6         10  
  6         145  
15              
16 6     6   32 use Carp;
  6         23  
  6         354  
17 6     6   2451 use IO::Socket;
  6         52883  
  6         27  
18 6     6   5036 use Net::Cmd;
  6         15  
  6         358  
19 6     6   1623 use Net::Config;
  6         13  
  6         618  
20 6     6   2516 use Time::Local;
  6         8511  
  6         522  
21              
22             our $VERSION = "3.15";
23              
24             # Code for detecting if we can use SSL
25             my $ssl_class = eval {
26             require IO::Socket::SSL;
27             # first version with default CA on most platforms
28 6     6   54 no warnings 'numeric';
  6         8  
  6         570  
29             IO::Socket::SSL->VERSION(2.007);
30             } && 'IO::Socket::SSL';
31              
32             my $nossl_warn = !$ssl_class &&
33             'To use SSL please install IO::Socket::SSL with version>=2.007';
34              
35             # Code for detecting if we can use IPv6
36             my $family_key = 'Domain';
37             my $inet6_class = eval {
38             require IO::Socket::IP;
39 6     6   50 no warnings 'numeric';
  6         12  
  6         408  
40             IO::Socket::IP->VERSION(0.25) || die;
41             $family_key = 'Family';
42             } && 'IO::Socket::IP' || eval {
43             require IO::Socket::INET6;
44 6     6   51 no warnings 'numeric';
  6         12  
  6         30652  
45             IO::Socket::INET6->VERSION(2.62);
46             } && 'IO::Socket::INET6';
47              
48              
49 3     3 1 303 sub can_ssl { $ssl_class };
50 1     1 1 157 sub can_inet6 { $inet6_class };
51              
52             our @ISA = ('Net::Cmd', $inet6_class || 'IO::Socket::INET');
53              
54              
55             sub new {
56 3     3 1 1244501 my $self = shift;
57 3   33     269 my $type = ref($self) || $self;
58 3         35 my ($host, %arg);
59 3 50       105 if (@_ % 2) {
60 0         0 $host = shift;
61 0         0 %arg = @_;
62             }
63             else {
64 3         123 %arg = @_;
65 3         37 $host = delete $arg{Host};
66             }
67 3         38 my $obj;
68              
69 3   0     49 $host ||= $ENV{NNTPSERVER} || $ENV{NEWSHOST};
      33        
70              
71 3 50       53 my $hosts = defined $host ? [$host] : $NetConfig{nntp_hosts};
72              
73 0         0 @{$hosts} = qw(news)
74 3 50       24 unless @{$hosts};
  3         33  
75              
76 3         175 my %connect = ( Proto => 'tcp');
77              
78 3 100       27 if ($arg{SSL}) {
79             # SSL from start
80 2 50       38 die $nossl_warn if ! $ssl_class;
81 2   50     6 $arg{Port} ||= 563;
82 2         68 $connect{$_} = $arg{$_} for(grep { m{^SSL_} } keys %arg);
  10         112  
83             }
84              
85 3         35 foreach my $o (qw(LocalAddr LocalPort Timeout)) {
86 9 50       69 $connect{$o} = $arg{$o} if exists $arg{$o};
87             }
88 3   33     56 $connect{$family_key} = $arg{Domain} || $arg{Family};
89 3 50       48 $connect{Timeout} = 120 unless defined $connect{Timeout};
90 3   50     24 $connect{PeerPort} = $arg{Port} || 'nntp(119)';
91 3         12 foreach my $h (@{$hosts}) {
  3         16  
92 3         33 $connect{PeerAddr} = $h;
93 3 50       330 $obj = $type->SUPER::new(%connect) or next;
94 3         6236 ${*$obj}{'net_nntp_host'} = $h;
  3         15  
95 3         27 ${*$obj}{'net_nntp_arg'} = \%arg;
  3         47  
96 3 100       15 if ($arg{SSL}) {
97 2 50       76 Net::NNTP::_SSL->start_SSL($obj,%arg) or next;
98             }
99             }
100              
101             return
102 3 50       10 unless defined $obj;
103              
104 3         23 $obj->autoflush(1);
105 3 50       320 $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
106              
107 3 50       114 unless ($obj->response() == CMD_OK) {
108 0         0 $obj->close;
109 0         0 return;
110             }
111              
112 3         57 my $c = $obj->code;
113 3         21 my @m = $obj->message;
114              
115 3 50 33     11 unless (exists $arg{Reader} && $arg{Reader} == 0) {
116              
117             # if server is INN and we have transfer rights the we are currently
118             # talking to innd not nnrpd
119 3 50       102 if ($obj->reader) {
120              
121             # If reader succeeds the we need to consider this code to determine postok
122 3         9 $c = $obj->code;
123             }
124             else {
125              
126             # I want to ignore this failure, so restore the previous status.
127 0         0 $obj->set_status($c, \@m);
128             }
129             }
130              
131 3 50       14 ${*$obj}{'net_nntp_post'} = $c == 200 ? 1 : 0;
  3         50  
132              
133 3         26 $obj;
134             }
135              
136              
137             sub host {
138 0     0 1 0 my $me = shift;
139 0         0 ${*$me}{'net_nntp_host'};
  0         0  
140             }
141              
142              
143             sub debug_text {
144 0     0 1 0 my $nntp = shift;
145 0         0 my $inout = shift;
146 0         0 my $text = shift;
147              
148 0 0 0     0 if ( (ref($nntp) and $nntp->code == 350 and $text =~ /^(\S+)/)
      0        
      0        
149             || ($text =~ /^(authinfo\s+pass)/io))
150             {
151 0         0 $text = "$1 ....\n";
152             }
153              
154 0         0 $text;
155             }
156              
157              
158             sub postok {
159 0 0   0 1 0 @_ == 1 or croak 'usage: $nntp->postok()';
160 0         0 my $nntp = shift;
161 0 0       0 ${*$nntp}{'net_nntp_post'} || 0;
  0         0  
162             }
163              
164              
165             sub starttls {
166 1     1 1 1561 my $self = shift;
167 1 50       5 $ssl_class or die $nossl_warn;
168 1 50       13 $self->_STARTTLS or return;
169             Net::NNTP::_SSL->start_SSL($self,
170 1 50       3 %{ ${*$self}{'net_nntp_arg'} }, # (ssl) args given in new
  1         2  
  1         33  
171             @_ # more (ssl) args
172             ) or return;
173 1         13 return 1;
174             }
175              
176              
177             sub article {
178 0 0 0 0 1 0 @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->article([{$msgid|$msgnum}[, $fh]])';
179 0         0 my $nntp = shift;
180 0         0 my @fh;
181              
182 0 0 0     0 @fh = (pop) if @_ == 2 || (@_ && (ref($_[0]) || ref(\$_[0]) eq 'GLOB'));
      0        
      0        
183              
184 0 0       0 $nntp->_ARTICLE(@_)
185             ? $nntp->read_until_dot(@fh)
186             : undef;
187             }
188              
189              
190             sub articlefh {
191 0 0 0 0 1 0 @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->articlefh([{$msgid|$msgnum}])';
192 0         0 my $nntp = shift;
193              
194 0 0       0 return unless $nntp->_ARTICLE(@_);
195 0         0 return $nntp->tied_fh;
196             }
197              
198              
199             sub authinfo {
200 0 0   0 1 0 @_ == 3 or croak 'usage: $nntp->authinfo($user, $pass)';
201 0         0 my ($nntp, $user, $pass) = @_;
202              
203 0 0       0 $nntp->_AUTHINFO("USER", $user) == CMD_MORE
204             && $nntp->_AUTHINFO("PASS", $pass) == CMD_OK;
205             }
206              
207              
208             sub authinfo_simple {
209 0 0   0 1 0 @_ == 3 or croak 'usage: $nntp->authinfo_simple($user, $pass)';
210 0         0 my ($nntp, $user, $pass) = @_;
211              
212 0 0       0 $nntp->_AUTHINFO('SIMPLE') == CMD_MORE
213             && $nntp->command($user, $pass)->response == CMD_OK;
214             }
215              
216              
217             sub body {
218 0 0 0 0 1 0 @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->body([{$msgid|$msgnum}[, $fh]])';
219 0         0 my $nntp = shift;
220 0         0 my @fh;
221              
222 0 0 0     0 @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
      0        
      0        
223              
224 0 0       0 $nntp->_BODY(@_)
225             ? $nntp->read_until_dot(@fh)
226             : undef;
227             }
228              
229              
230             sub bodyfh {
231 0 0 0 0 1 0 @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->bodyfh([{$msgid|$msgnum}])';
232 0         0 my $nntp = shift;
233 0 0       0 return unless $nntp->_BODY(@_);
234 0         0 return $nntp->tied_fh;
235             }
236              
237              
238             sub head {
239 0 0 0 0 1 0 @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->head([{$msgid|$msgnum}[, $fh]])';
240 0         0 my $nntp = shift;
241 0         0 my @fh;
242              
243 0 0 0     0 @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
      0        
      0        
244              
245 0 0       0 $nntp->_HEAD(@_)
246             ? $nntp->read_until_dot(@fh)
247             : undef;
248             }
249              
250              
251             sub headfh {
252 0 0 0 0 1 0 @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->headfh([{$msgid|$msgnum}])';
253 0         0 my $nntp = shift;
254 0 0       0 return unless $nntp->_HEAD(@_);
255 0         0 return $nntp->tied_fh;
256             }
257              
258              
259             sub nntpstat {
260 0 0 0 0 1 0 @_ == 1 || @_ == 2 or croak 'usage: $nntp->nntpstat([{$msgid|$msgnum}])';
261 0         0 my $nntp = shift;
262              
263 0 0 0     0 $nntp->_STAT(@_) && $nntp->message =~ /(<[^>]+>)/o
264             ? $1
265             : undef;
266             }
267              
268              
269             sub group {
270 0 0 0 0 1 0 @_ == 1 || @_ == 2 or croak 'usage: $nntp->group([$group])';
271 0         0 my $nntp = shift;
272 0         0 my $grp = ${*$nntp}{'net_nntp_group'};
  0         0  
273              
274 0 0 0     0 return $grp
275             unless (@_ || wantarray);
276              
277 0         0 my $newgrp = shift;
278              
279 0 0 0     0 $newgrp = (defined($grp) and length($grp)) ? $grp : ""
    0 0        
280             unless defined($newgrp) and length($newgrp);
281              
282             return
283 0 0 0     0 unless $nntp->_GROUP($newgrp) and $nntp->message =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S+)/;
284              
285 0         0 my ($count, $first, $last, $group) = ($1, $2, $3, $4);
286              
287             # group may be replied as '(current group)'
288 0 0       0 $group = ${*$nntp}{'net_nntp_group'}
  0         0  
289             if $group =~ /\(/;
290              
291 0         0 ${*$nntp}{'net_nntp_group'} = $group;
  0         0  
292              
293             wantarray
294 0 0       0 ? ($count, $first, $last, $group)
295             : $group;
296             }
297              
298              
299             sub help {
300 0 0   0 1 0 @_ == 1 or croak 'usage: $nntp->help()';
301 0         0 my $nntp = shift;
302              
303 0 0       0 $nntp->_HELP
304             ? $nntp->read_until_dot
305             : undef;
306             }
307              
308              
309             sub ihave {
310 0 0   0 1 0 @_ >= 2 or croak 'usage: $nntp->ihave($msgid[, $message])';
311 0         0 my $nntp = shift;
312 0         0 my $msgid = shift;
313              
314 0 0 0     0 $nntp->_IHAVE($msgid) && $nntp->datasend(@_)
      0        
315             ? @_ == 0 || $nntp->dataend
316             : undef;
317             }
318              
319              
320             sub last {
321 0 0   0 1 0 @_ == 1 or croak 'usage: $nntp->last()';
322 0         0 my $nntp = shift;
323              
324 0 0 0     0 $nntp->_LAST && $nntp->message =~ /(<[^>]+>)/o
325             ? $1
326             : undef;
327             }
328              
329              
330             sub list {
331 0 0   0 1 0 @_ == 1 or croak 'usage: $nntp->list()';
332 0         0 my $nntp = shift;
333              
334 0 0       0 $nntp->_LIST
335             ? $nntp->_grouplist
336             : undef;
337             }
338              
339              
340             sub newgroups {
341 0 0   0 1 0 @_ >= 2 or croak 'usage: $nntp->newgroups($since[, $distributions])';
342 0         0 my $nntp = shift;
343 0         0 my $since = _timestr(shift);
344 0   0     0 my $distributions = shift || "";
345              
346 0 0       0 $distributions = join(",", @{$distributions})
  0         0  
347             if ref($distributions);
348              
349 0 0       0 $nntp->_NEWGROUPS($since, $distributions)
350             ? $nntp->_grouplist
351             : undef;
352             }
353              
354              
355             sub newnews {
356 0 0 0 0 1 0 @_ >= 2 && @_ <= 4
357             or croak 'usage: $nntp->newnews($since[, $groups[, $distributions]])';
358 0         0 my $nntp = shift;
359 0         0 my $since = _timestr(shift);
360 0 0       0 my $groups = @_ ? shift : $nntp->group;
361 0   0     0 my $distributions = shift || "";
362              
363 0   0     0 $groups ||= "*";
364 0 0       0 $groups = join(",", @{$groups})
  0         0  
365             if ref($groups);
366              
367 0 0       0 $distributions = join(",", @{$distributions})
  0         0  
368             if ref($distributions);
369              
370 0 0       0 $nntp->_NEWNEWS($groups, $since, $distributions)
371             ? $nntp->_articlelist
372             : undef;
373             }
374              
375              
376             sub next {
377 0 0   0 1 0 @_ == 1 or croak 'usage: $nntp->next()';
378 0         0 my $nntp = shift;
379              
380 0 0 0     0 $nntp->_NEXT && $nntp->message =~ /(<[^>]+>)/o
381             ? $1
382             : undef;
383             }
384              
385              
386             sub post {
387 0 0   0 1 0 @_ >= 1 or croak 'usage: $nntp->post([$message])';
388 0         0 my $nntp = shift;
389              
390 0 0 0     0 $nntp->_POST() && $nntp->datasend(@_)
      0        
391             ? @_ == 0 || $nntp->dataend
392             : undef;
393             }
394              
395              
396             sub postfh {
397 0     0 1 0 my $nntp = shift;
398 0 0       0 return unless $nntp->_POST();
399 0         0 return $nntp->tied_fh;
400             }
401              
402              
403             sub quit {
404 3 50   3 1 3247 @_ == 1 or croak 'usage: $nntp->quit()';
405 3         9 my $nntp = shift;
406              
407 3         59 $nntp->_QUIT;
408 3         30 $nntp->close;
409             }
410              
411              
412             sub slave {
413 0 0   0 1 0 @_ == 1 or croak 'usage: $nntp->slave()';
414 0         0 my $nntp = shift;
415              
416 0         0 $nntp->_SLAVE;
417             }
418              
419             ##
420             ## The following methods are not implemented by all servers
421             ##
422              
423              
424             sub active {
425 0 0 0 0 1 0 @_ == 1 || @_ == 2 or croak 'usage: $nntp->active([$pattern])';
426 0         0 my $nntp = shift;
427              
428 0 0       0 $nntp->_LIST('ACTIVE', @_)
429             ? $nntp->_grouplist
430             : undef;
431             }
432              
433              
434             sub active_times {
435 0 0   0 1 0 @_ == 1 or croak 'usage: $nntp->active_times()';
436 0         0 my $nntp = shift;
437              
438 0 0       0 $nntp->_LIST('ACTIVE.TIMES')
439             ? $nntp->_grouplist
440             : undef;
441             }
442              
443              
444             sub distributions {
445 0 0   0 1 0 @_ == 1 or croak 'usage: $nntp->distributions()';
446 0         0 my $nntp = shift;
447              
448 0 0       0 $nntp->_LIST('DISTRIBUTIONS')
449             ? $nntp->_description
450             : undef;
451             }
452              
453              
454             sub distribution_patterns {
455 0 0   0 1 0 @_ == 1 or croak 'usage: $nntp->distribution_patterns()';
456 0         0 my $nntp = shift;
457              
458 0         0 my $arr;
459 0         0 local $_;
460              
461             ## no critic (ControlStructures::ProhibitMutatingListFunctions)
462             $nntp->_LIST('DISTRIB.PATS')
463             && ($arr = $nntp->read_until_dot)
464 0 0 0     0 ? [grep { /^\d/ && (chomp, $_ = [split /:/]) } @$arr]
  0 0       0  
465             : undef;
466             }
467              
468              
469             sub newsgroups {
470 0 0 0 0 1 0 @_ == 1 || @_ == 2 or croak 'usage: $nntp->newsgroups([$pattern])';
471 0         0 my $nntp = shift;
472              
473 0 0       0 $nntp->_LIST('NEWSGROUPS', @_)
474             ? $nntp->_description
475             : undef;
476             }
477              
478              
479             sub overview_fmt {
480 0 0   0 1 0 @_ == 1 or croak 'usage: $nntp->overview_fmt()';
481 0         0 my $nntp = shift;
482              
483 0 0       0 $nntp->_LIST('OVERVIEW.FMT')
484             ? $nntp->_articlelist
485             : undef;
486             }
487              
488              
489             sub subscriptions {
490 0 0   0 1 0 @_ == 1 or croak 'usage: $nntp->subscriptions()';
491 0         0 my $nntp = shift;
492              
493 0 0       0 $nntp->_LIST('SUBSCRIPTIONS')
494             ? $nntp->_articlelist
495             : undef;
496             }
497              
498              
499             sub listgroup {
500 0 0 0 0 1 0 @_ == 1 || @_ == 2 or croak 'usage: $nntp->listgroup([$group])';
501 0         0 my $nntp = shift;
502              
503 0 0       0 $nntp->_LISTGROUP(@_)
504             ? $nntp->_articlelist
505             : undef;
506             }
507              
508              
509             sub reader {
510 3 50   3 1 13 @_ == 1 or croak 'usage: $nntp->reader()';
511 3         6 my $nntp = shift;
512              
513 3         79 $nntp->_MODE('READER');
514             }
515              
516              
517             sub xgtitle {
518 0 0 0 0 1 0 @_ == 1 || @_ == 2 or croak 'usage: $nntp->xgtitle([$pattern])';
519 0         0 my $nntp = shift;
520              
521 0 0       0 $nntp->_XGTITLE(@_)
522             ? $nntp->_description
523             : undef;
524             }
525              
526              
527             sub xhdr {
528 0 0 0 0 1 0 @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr($header[, $message_spec])';
529 0         0 my $nntp = shift;
530 0         0 my $header = shift;
531 0         0 my $arg = _msg_arg(@_);
532              
533 0 0       0 $nntp->_XHDR($header, $arg)
534             ? $nntp->_description
535             : undef;
536             }
537              
538              
539             sub xover {
540 0 0 0 0 1 0 @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover($message_spec)';
541 0         0 my $nntp = shift;
542 0         0 my $arg = _msg_arg(@_);
543              
544 0 0       0 $nntp->_XOVER($arg)
545             ? $nntp->_fieldlist
546             : undef;
547             }
548              
549              
550             sub xpat {
551 0 0 0 0 1 0 @_ == 4 || @_ == 5 or croak 'usage: $nntp->xpat($header, $pattern, $message_spec )';
552 0         0 my $nntp = shift;
553 0         0 my $header = shift;
554 0         0 my $pattern = shift;
555 0         0 my $arg = _msg_arg(@_);
556              
557 0 0       0 $pattern = join(" ", @$pattern)
558             if ref($pattern);
559              
560 0 0       0 $nntp->_XPAT($header, $arg, $pattern)
561             ? $nntp->_description
562             : undef;
563             }
564              
565              
566             sub xpath {
567 0 0   0 1 0 @_ == 2 or croak 'usage: $nntp->xpath($message_id)';
568 0         0 my ($nntp, $message_id) = @_;
569              
570             return
571 0 0       0 unless $nntp->_XPATH($message_id);
572              
573 0         0 my $m;
574 0         0 ($m = $nntp->message) =~ s/^\d+\s+//o;
575 0         0 my @p = split /\s+/, $m;
576              
577 0 0       0 wantarray ? @p : $p[0];
578             }
579              
580              
581             sub xrover {
582 0 0 0 0 1 0 @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover($message_spec)';
583 0         0 my $nntp = shift;
584 0         0 my $arg = _msg_arg(@_);
585              
586 0 0       0 $nntp->_XROVER($arg)
587             ? $nntp->_description
588             : undef;
589             }
590              
591              
592             sub date {
593 0 0   0 1 0 @_ == 1 or croak 'usage: $nntp->date()';
594 0         0 my $nntp = shift;
595              
596 0 0 0     0 $nntp->_DATE
597             && $nntp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
598             ? timegm($6, $5, $4, $3, $2 - 1, $1)
599             : undef;
600             }
601              
602              
603             ##
604             ## Private subroutines
605             ##
606              
607              
608             sub _msg_arg {
609 0     0   0 my $spec = shift;
610 0         0 my $arg = "";
611              
612 0 0       0 if (@_) {
613 0 0       0 carp "Depriciated passing of two message numbers, " . "pass a reference"
614             if $^W;
615 0         0 $spec = [$spec, $_[0]];
616             }
617              
618 0 0       0 if (defined $spec) {
619 0 0       0 if (ref($spec)) {
620 0         0 $arg = $spec->[0];
621 0 0       0 if (defined $spec->[1]) {
622 0 0       0 $arg .= "-"
623             if $spec->[1] != $spec->[0];
624 0 0       0 $arg .= $spec->[1]
625             if $spec->[1] > $spec->[0];
626             }
627             }
628             else {
629 0         0 $arg = $spec;
630             }
631             }
632              
633 0         0 $arg;
634             }
635              
636              
637             sub _timestr {
638 0     0   0 my $time = shift;
639 0         0 my @g = reverse((gmtime($time))[0 .. 5]);
640 0         0 $g[1] += 1;
641 0         0 $g[0] %= 100;
642 0         0 sprintf "%02d%02d%02d %02d%02d%02d GMT", @g;
643             }
644              
645              
646             sub _grouplist {
647 0     0   0 my $nntp = shift;
648 0 0       0 my $arr = $nntp->read_until_dot
649             or return;
650              
651 0         0 my $hash = {};
652              
653 0         0 foreach my $ln (@$arr) {
654 0         0 my @a = split(/[\s\n]+/, $ln);
655 0         0 $hash->{$a[0]} = [@a[1, 2, 3]];
656             }
657              
658 0         0 $hash;
659             }
660              
661              
662             sub _fieldlist {
663 0     0   0 my $nntp = shift;
664 0 0       0 my $arr = $nntp->read_until_dot
665             or return;
666              
667 0         0 my $hash = {};
668              
669 0         0 foreach my $ln (@$arr) {
670 0         0 my @a = split(/[\t\n]/, $ln);
671 0         0 my $m = shift @a;
672 0         0 $hash->{$m} = [@a];
673             }
674              
675 0         0 $hash;
676             }
677              
678              
679             sub _articlelist {
680 0     0   0 my $nntp = shift;
681 0         0 my $arr = $nntp->read_until_dot;
682              
683 0 0       0 chomp(@$arr)
684             if $arr;
685              
686 0         0 $arr;
687             }
688              
689              
690             sub _description {
691 0     0   0 my $nntp = shift;
692 0 0       0 my $arr = $nntp->read_until_dot
693             or return;
694              
695 0         0 my $hash = {};
696              
697 0         0 foreach my $ln (@$arr) {
698 0         0 chomp($ln);
699              
700 0 0       0 $hash->{$1} = $ln
701             if $ln =~ s/^\s*(\S+)\s*//o;
702             }
703              
704 0         0 $hash;
705              
706             }
707              
708             ##
709             ## The commands
710             ##
711              
712              
713 0     0   0 sub _ARTICLE { shift->command('ARTICLE', @_)->response == CMD_OK }
714 0     0   0 sub _AUTHINFO { shift->command('AUTHINFO', @_)->response }
715 0     0   0 sub _BODY { shift->command('BODY', @_)->response == CMD_OK }
716 0     0   0 sub _DATE { shift->command('DATE')->response == CMD_INFO }
717 0     0   0 sub _GROUP { shift->command('GROUP', @_)->response == CMD_OK }
718 0     0   0 sub _HEAD { shift->command('HEAD', @_)->response == CMD_OK }
719 0     0   0 sub _HELP { shift->command('HELP', @_)->response == CMD_INFO }
720 0     0   0 sub _IHAVE { shift->command('IHAVE', @_)->response == CMD_MORE }
721 0     0   0 sub _LAST { shift->command('LAST')->response == CMD_OK }
722 0     0   0 sub _LIST { shift->command('LIST', @_)->response == CMD_OK }
723 0     0   0 sub _LISTGROUP { shift->command('LISTGROUP', @_)->response == CMD_OK }
724 0     0   0 sub _NEWGROUPS { shift->command('NEWGROUPS', @_)->response == CMD_OK }
725 0     0   0 sub _NEWNEWS { shift->command('NEWNEWS', @_)->response == CMD_OK }
726 0     0   0 sub _NEXT { shift->command('NEXT')->response == CMD_OK }
727 0     0   0 sub _POST { shift->command('POST', @_)->response == CMD_MORE }
728 3     3   16 sub _QUIT { shift->command('QUIT', @_)->response == CMD_OK }
729 0     0   0 sub _SLAVE { shift->command('SLAVE', @_)->response == CMD_OK }
730 1     1   5 sub _STARTTLS { shift->command("STARTTLS")->response() == CMD_MORE }
731 0     0   0 sub _STAT { shift->command('STAT', @_)->response == CMD_OK }
732 3     3   57 sub _MODE { shift->command('MODE', @_)->response == CMD_OK }
733 0     0   0 sub _XGTITLE { shift->command('XGTITLE', @_)->response == CMD_OK }
734 0     0   0 sub _XHDR { shift->command('XHDR', @_)->response == CMD_OK }
735 0     0   0 sub _XPAT { shift->command('XPAT', @_)->response == CMD_OK }
736 0     0   0 sub _XPATH { shift->command('XPATH', @_)->response == CMD_OK }
737 0     0   0 sub _XOVER { shift->command('XOVER', @_)->response == CMD_OK }
738 0     0   0 sub _XROVER { shift->command('XROVER', @_)->response == CMD_OK }
739 0     0   0 sub _XTHREAD { shift->unsupported }
740 0     0   0 sub _XSEARCH { shift->unsupported }
741 0     0   0 sub _XINDEX { shift->unsupported }
742              
743             ##
744             ## IO/perl methods
745             ##
746              
747              
748             sub DESTROY {
749 0     0   0 my $nntp = shift;
750 0 0       0 defined(fileno($nntp)) && $nntp->quit;
751             }
752              
753             {
754             package Net::NNTP::_SSL;
755             our @ISA = ( $ssl_class ? ($ssl_class):(), 'Net::NNTP' );
756 0     0   0 sub starttls { die "NNTP connection is already in SSL mode" }
757             sub start_SSL {
758 3     3   21 my ($class,$nntp,%arg) = @_;
759 3         36 delete @arg{ grep { !m{^SSL_} } keys %arg };
  14         100  
760 3   33     43 ( $arg{SSL_verifycn_name} ||= $nntp->host )
761             =~s{(?
762             $arg{SSL_hostname} = $arg{SSL_verifycn_name}
763 3 50 33     149 if ! defined $arg{SSL_hostname} && $class->can_client_sni;
764 3         86 my $ok = $class->SUPER::start_SSL($nntp,
765             SSL_verifycn_scheme => 'nntp',
766             %arg
767             );
768 3 50       26516 $@ = $ssl_class->errstr if !$ok;
769 3         22 return $ok;
770             }
771             }
772              
773              
774              
775              
776             1;
777              
778             __END__