perl-libnet.git  about / heads / tags
Unnamed repository; edit this file 'description' to name the repository.
blob 90b568521a735c3d087005339ec55d35b7efc471 3424 bytes (raw)
$ git show nntp-compress:lib/Net/NNTP/Deflate.pm	# shows this blob on the CLI

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
 
# Net::NNTP::Deflate
#
# Copyright (C) 2019 Eric Wong <e@80x24.org>
#
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# support NNTP COMPRESS DEFLATE as specified in RFC 8054.  This
# is an internal class intended for use by Net::NNTP use, only
#
# This is done via subclassing and SUPER.  tie can't seem to work
# since it doesn't seem to stack and layer with IO::Socket::SSL
# (which also uses tie).  PerlIO won't work, either, since Net::Cmd
# depends on sysread/syswrite semantics for timeouts.
package Net::NNTP::Deflate;

use 5.008001;

use strict;
use warnings;

use Compress::Raw::Zlib;
use base qw(Net::NNTP);
my %ZOPT = ( -WindowBits => -15, -AppendOutput => 1 );
use Errno qw(ECONNRESET);

sub compression { 'DEFLATE' }

sub wrap {
  my ($class, $self) = @_;
  my ($zin, $zout, $err);

  ($zin, $err) = Compress::Raw::Zlib::Inflate->new(%ZOPT);
  $err == Z_OK or die "Inflate->new failed: $err\n";
  ${*$self}{net_nntp_inflate} = [ $zin, '' ];

  ($zout, $err) = Compress::Raw::Zlib::Deflate->new(%ZOPT);
  $err == Z_OK or die "Deflate->new failed: $err\n";
  ${*$self}{net_nntp_deflate} = [ $zout, '', 0 ];

  # We need to capture these methods now, otherwise tied calls via
  # IO::Socket::SSL::SSL_HANDLE::* will infinitely recurse.
  # XXX sysread/syswrite are obviously needed for wrapping,
  # but I don't understand why close and fileno wrappers are needed,
  # but infinite recursion ensues without them :<
  for my $m (qw(sysread syswrite close fileno)) {
    ${*$self}{"net_nntp_$m"} = $self->can($m);
  }

  $class .= 'SSL' if $self->isa('IO::Socket::SSL');
  bless $self, $class;
}

sub fileno {
  my $self = shift;
  ${*$self}{net_nntp_fileno}->($self);
}

sub close {
  my $self = shift;
  ${*$self}{net_nntp_close}->($self);
}

sub syswrite {
  my ($self, undef, $len, $off) = @_;
  my $de = ${*$self}{net_nntp_deflate};
  my $zout = $de->[0];

  $off = 0 unless defined($off);
  $len = bytes::length($_[1]) unless defined($len);

  my $err = $zout->deflate(substr($_[1], $off, $len), $de->[1]);
  $err == Z_OK or die "->deflate failed: $err";

  $err = $zout->flush($de->[1], Z_PARTIAL_FLUSH);
  $err == Z_OK or die "->flush failed: $err";

  my $olen = length($de->[1]);
  my $w = ${*$self}{net_nntp_syswrite}->($self, $de->[1], $olen, $de->[2]);
  defined($w) or return;

  if ($olen == $w) { # all done!
    $de->[1] = '';
    $de->[2] = 0;
  }
  else { # try again, later
    $de->[2] += $w;
  }

  $len;
}

# note: only intended for Net::Cmd use, so returning extra data
# beyond $len won't matter
sub sysread {
  my ($self, undef, $len, $off) = @_;

  if (!defined($off) || $off != length($_[1])) {
    die __PACKAGE__.'::sysread is only intended for Net::Cmd use';
  }

  my $in = ${*$self}{net_nntp_inflate};

  while (1) {
    my $ioff = length($in->[1]);
    my $r = ${*$self}{net_nntp_sysread}->($self, $in->[1], $len, $ioff);
    $r or return $r; # $r may be undef or 0

    my $err = $in->[0]->inflate($in->[1], $_[1]); # consumes $in->[1]
    if ($err == Z_OK) {
      $r = length($_[1]);
      return $r if $r;
      next;
    }

    return 0 if $err == Z_STREAM_END;

    # some other error from ->inflate, probably not recoverable
    warn "Error: $err from ".ref($in->[0])."::inflate\n";
    $! = ECONNRESET;
    return;
  }
}

package Net::NNTP::DeflateSSL;
use base qw(Net::NNTP::Deflate Net::NNTP::_SSL);

1;

git clone https://80x24.org/perl-libnet.git