init III

Perl OTRS/Kernel/cpan-lib/Net/HTTP.pm

@@ -0,0 +1,307 @@
+package Net::HTTP;
+$Net::HTTP::VERSION = '6.17';
+use strict;
+use warnings;
+
+use vars qw($SOCKET_CLASS);
+unless ($SOCKET_CLASS) {
+    # Try several, in order of capability and preference
+    if (eval { require IO::Socket::IP }) {
+       $SOCKET_CLASS = "IO::Socket::IP";    # IPv4+IPv6
+    } elsif (eval { require IO::Socket::INET6 }) {
+       $SOCKET_CLASS = "IO::Socket::INET6"; # IPv4+IPv6
+    } elsif (eval { require IO::Socket::INET }) {
+       $SOCKET_CLASS = "IO::Socket::INET";  # IPv4 only
+    } else {
+       require IO::Socket;
+       $SOCKET_CLASS = "IO::Socket::INET";
+    }
+}
+require Net::HTTP::Methods;
+require Carp;
+
+our @ISA = ($SOCKET_CLASS, 'Net::HTTP::Methods');
+
+sub new {
+    my $class = shift;
+    Carp::croak("No Host option provided") unless @_;
+    $class->SUPER::new(@_);
+}
+
+sub configure {
+    my($self, $cnf) = @_;
+    $self->http_configure($cnf);
+}
+
+sub http_connect {
+    my($self, $cnf) = @_;
+    $self->SUPER::configure($cnf);
+}
+
+1;
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Net::HTTP - Low-level HTTP connection (client)
+
+=head1 VERSION
+
+version 6.17
+
+=head1 SYNOPSIS
+
+ use Net::HTTP;
+ my $s = Net::HTTP->new(Host => "www.perl.com") || die $@;
+ $s->write_request(GET => "/", 'User-Agent' => "Mozilla/5.0");
+ my($code, $mess, %h) = $s->read_response_headers;
+
+ while (1) {
+    my $buf;
+    my $n = $s->read_entity_body($buf, 1024);
+    die "read failed: $!" unless defined $n;
+    last unless $n;
+    print $buf;
+ }
+
+=head1 DESCRIPTION
+
+The C<Net::HTTP> class is a low-level HTTP client.  An instance of the
+C<Net::HTTP> class represents a connection to an HTTP server.  The
+HTTP protocol is described in RFC 2616.  The C<Net::HTTP> class
+supports C<HTTP/1.0> and C<HTTP/1.1>.
+
+C<Net::HTTP> is a sub-class of one of C<IO::Socket::IP> (IPv6+IPv4),
+C<IO::Socket::INET6> (IPv6+IPv4), or C<IO::Socket::INET> (IPv4 only).  
+You can mix the methods described below with reading and writing from the
+socket directly.  This is not necessary a good idea, unless you know what
+you are doing.
+
+The following methods are provided (in addition to those of
+C<IO::Socket::INET>):
+
+=over
+
+=item $s = Net::HTTP->new( %options )
+
+The C<Net::HTTP> constructor method takes the same options as
+C<IO::Socket::INET>'s as well as these:
+
+  Host:            Initial host attribute value
+  KeepAlive:       Initial keep_alive attribute value
+  SendTE:          Initial send_te attribute_value
+  HTTPVersion:     Initial http_version attribute value
+  PeerHTTPVersion: Initial peer_http_version attribute value
+  MaxLineLength:   Initial max_line_length attribute value
+  MaxHeaderLines:  Initial max_header_lines attribute value
+
+The C<Host> option is also the default for C<IO::Socket::INET>'s
+C<PeerAddr>.  The C<PeerPort> defaults to 80 if not provided.
+The C<PeerPort> specification can also be embedded in the C<PeerAddr>
+by preceding it with a ":", and closing the IPv6 address on brackets "[]" if
+necessary: "192.0.2.1:80","[2001:db8::1]:80","any.example.com:80".
+
+The C<Listen> option provided by C<IO::Socket::INET>'s constructor
+method is not allowed.
+
+If unable to connect to the given HTTP server then the constructor
+returns C<undef> and $@ contains the reason.  After a successful
+connect, a C<Net:HTTP> object is returned.
+
+=item $s->host
+
+Get/set the default value of the C<Host> header to send.  The $host
+must not be set to an empty string (or C<undef>) for HTTP/1.1.
+
+=item $s->keep_alive
+
+Get/set the I<keep-alive> value.  If this value is TRUE then the
+request will be sent with headers indicating that the server should try
+to keep the connection open so that multiple requests can be sent.
+
+The actual headers set will depend on the value of the C<http_version>
+and C<peer_http_version> attributes.
+
+=item $s->send_te
+
+Get/set the a value indicating if the request will be sent with a "TE"
+header to indicate the transfer encodings that the server can choose to
+use.  The list of encodings announced as accepted by this client depends
+on availability of the following modules: C<Compress::Raw::Zlib> for
+I<deflate>, and C<IO::Compress::Gunzip> for I<gzip>.
+
+=item $s->http_version
+
+Get/set the HTTP version number that this client should announce.
+This value can only be set to "1.0" or "1.1".  The default is "1.1".
+
+=item $s->peer_http_version
+
+Get/set the protocol version number of our peer.  This value will
+initially be "1.0", but will be updated by a successful
+read_response_headers() method call.
+
+=item $s->max_line_length
+
+Get/set a limit on the length of response line and response header
+lines.  The default is 8192.  A value of 0 means no limit.
+
+=item $s->max_header_length
+
+Get/set a limit on the number of header lines that a response can
+have.  The default is 128.  A value of 0 means no limit.
+
+=item $s->format_request($method, $uri, %headers, [$content])
+
+Format a request message and return it as a string.  If the headers do
+not include a C<Host> header, then a header is inserted with the value
+of the C<host> attribute.  Headers like C<Connection> and
+C<Keep-Alive> might also be added depending on the status of the
+C<keep_alive> attribute.
+
+If $content is given (and it is non-empty), then a C<Content-Length>
+header is automatically added unless it was already present.
+
+=item $s->write_request($method, $uri, %headers, [$content])
+
+Format and send a request message.  Arguments are the same as for
+format_request().  Returns true if successful.
+
+=item $s->format_chunk( $data )
+
+Returns the string to be written for the given chunk of data.  
+
+=item $s->write_chunk($data)
+
+Will write a new chunk of request entity body data.  This method
+should only be used if the C<Transfer-Encoding> header with a value of
+C<chunked> was sent in the request.  Note, writing zero-length data is
+a no-op.  Use the write_chunk_eof() method to signal end of entity
+body data.
+
+Returns true if successful.
+
+=item $s->format_chunk_eof( %trailers )
+
+Returns the string to be written for signaling EOF when a
+C<Transfer-Encoding> of C<chunked> is used.
+
+=item $s->write_chunk_eof( %trailers )
+
+Will write eof marker for chunked data and optional trailers.  Note
+that trailers should not really be used unless is was signaled
+with a C<Trailer> header.
+
+Returns true if successful.
+
+=item ($code, $mess, %headers) = $s->read_response_headers( %opts )
+
+Read response headers from server and return it.  The $code is the 3
+digit HTTP status code (see L<HTTP::Status>) and $mess is the textual
+message that came with it.  Headers are then returned as key/value
+pairs.  Since key letter casing is not normalized and the same key can
+even occur multiple times, assigning these values directly to a hash
+is not wise.  Only the $code is returned if this method is called in
+scalar context.
+
+As a side effect this method updates the 'peer_http_version'
+attribute.
+
+Options might be passed in as key/value pairs.  There are currently
+only two options supported; C<laxed> and C<junk_out>.
+
+The C<laxed> option will make read_response_headers() more forgiving
+towards servers that have not learned how to speak HTTP properly.  The
+C<laxed> option is a boolean flag, and is enabled by passing in a TRUE
+value.  The C<junk_out> option can be used to capture bad header lines
+when C<laxed> is enabled.  The value should be an array reference.
+Bad header lines will be pushed onto the array.
+
+The C<laxed> option must be specified in order to communicate with
+pre-HTTP/1.0 servers that don't describe the response outcome or the
+data they send back with a header block.  For these servers
+peer_http_version is set to "0.9" and this method returns (200,
+"Assumed OK").
+
+The method will raise an exception (die) if the server does not speak
+proper HTTP or if the C<max_line_length> or C<max_header_length>
+limits are reached.  If the C<laxed> option is turned on and
+C<max_line_length> and C<max_header_length> checks are turned off,
+then no exception will be raised and this method will always
+return a response code.
+
+=item $n = $s->read_entity_body($buf, $size);
+
+Reads chunks of the entity body content.  Basically the same interface
+as for read() and sysread(), but the buffer offset argument is not
+supported yet.  This method should only be called after a successful
+read_response_headers() call.
+
+The return value will be C<undef> on read errors, 0 on EOF, -1 if no data
+could be returned this time, otherwise the number of bytes assigned
+to $buf.  The $buf is set to "" when the return value is -1.
+
+You normally want to retry this call if this function returns either
+-1 or C<undef> with C<$!> as EINTR or EAGAIN (see L<Errno>).  EINTR
+can happen if the application catches signals and EAGAIN can happen if
+you made the socket non-blocking.
+
+This method will raise exceptions (die) if the server does not speak
+proper HTTP.  This can only happen when reading chunked data.
+
+=item %headers = $s->get_trailers
+
+After read_entity_body() has returned 0 to indicate end of the entity
+body, you might call this method to pick up any trailers.
+
+=item $s->_rbuf
+
+Get/set the read buffer content.  The read_response_headers() and
+read_entity_body() methods use an internal buffer which they will look
+for data before they actually sysread more from the socket itself.  If
+they read too much, the remaining data will be left in this buffer.
+
+=item $s->_rbuf_length
+
+Returns the number of bytes in the read buffer.  This should always be
+the same as:
+
+    length($s->_rbuf)
+
+but might be more efficient.
+
+=back
+
+=head1 SUBCLASSING
+
+The read_response_headers() and read_entity_body() will invoke the
+sysread() method when they need more data.  Subclasses might want to
+override this method to control how reading takes place.
+
+The object itself is a glob.  Subclasses should avoid using hash key
+names prefixed with C<http_> and C<io_>.
+
+=head1 SEE ALSO
+
+L<LWP>, L<IO::Socket::INET>, L<Net::HTTP::NB>
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@activestate.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2001-2017 by Gisle Aas.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
+
+__END__
+
+# ABSTRACT: Low-level HTTP connection (client)
+

Perl OTRS/Kernel/cpan-lib/Net/HTTP/Methods.pm

@@ -0,0 +1,669 @@
+package Net::HTTP::Methods;
+$Net::HTTP::Methods::VERSION = '6.17';
+use strict;
+use warnings;
+use URI;
+
+my $CRLF = "\015\012";   # "\r\n" is not portable
+
+*_bytes = defined(&utf8::downgrade) ?
+    sub {
+        unless (utf8::downgrade($_[0], 1)) {
+            require Carp;
+            Carp::croak("Wide character in HTTP request (bytes required)");
+        }
+        return $_[0];
+    }
+    :
+    sub {
+        return $_[0];
+    };
+
+
+sub new {
+    my $class = shift;
+    unshift(@_, "Host") if @_ == 1;
+    my %cnf = @_;
+    require Symbol;
+    my $self = bless Symbol::gensym(), $class;
+    return $self->http_configure(\%cnf);
+}
+
+sub http_configure {
+    my($self, $cnf) = @_;
+
+    die "Listen option not allowed" if $cnf->{Listen};
+    my $explicit_host = (exists $cnf->{Host});
+    my $host = delete $cnf->{Host};
+    my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost};
+    if (!$peer) {
+	die "No Host option provided" unless $host;
+	$cnf->{PeerAddr} = $peer = $host;
+    }
+
+    # CONNECTIONS
+    # PREFER: port number from PeerAddr, then PeerPort, then http_default_port
+    my $peer_uri = URI->new("http://$peer");
+    $cnf->{"PeerPort"} =  $peer_uri->_port || $cnf->{PeerPort} ||  $self->http_default_port;
+    $cnf->{"PeerAddr"} = $peer_uri->host;
+
+    # HOST header:
+    # If specified but blank, ignore.
+    # If specified with a value, add the port number
+    # If not specified, set to PeerAddr and port number
+    # ALWAYS: If IPv6 address, use [brackets]  (thanks to the URI package)
+    # ALWAYS: omit port number if http_default_port
+    if (($host) || (! $explicit_host)) {
+        my $uri =  ($explicit_host) ? URI->new("http://$host") : $peer_uri->clone;
+        if (!$uri->_port) {
+            # Always use *our*  $self->http_default_port  instead of URI's  (Covers HTTP, HTTPS)
+            $uri->port( $cnf->{PeerPort} ||  $self->http_default_port);
+        }
+        my $host_port = $uri->host_port;               # Returns host:port or [ipv6]:port
+        my $remove = ":" . $self->http_default_port;   # we want to remove the default port number
+        if (substr($host_port,0-length($remove)) eq $remove) {
+            substr($host_port,0-length($remove)) = "";
+        }
+        $host = $host_port;
+    }
+
+    $cnf->{Proto} = 'tcp';
+
+    my $keep_alive = delete $cnf->{KeepAlive};
+    my $http_version = delete $cnf->{HTTPVersion};
+    $http_version = "1.1" unless defined $http_version;
+    my $peer_http_version = delete $cnf->{PeerHTTPVersion};
+    $peer_http_version = "1.0" unless defined $peer_http_version;
+    my $send_te = delete $cnf->{SendTE};
+    my $max_line_length = delete $cnf->{MaxLineLength};
+    $max_line_length = 8*1024 unless defined $max_line_length;
+    my $max_header_lines = delete $cnf->{MaxHeaderLines};
+    $max_header_lines = 128 unless defined $max_header_lines;
+
+    return undef unless $self->http_connect($cnf);
+
+    $self->host($host);
+    $self->keep_alive($keep_alive);
+    $self->send_te($send_te);
+    $self->http_version($http_version);
+    $self->peer_http_version($peer_http_version);
+    $self->max_line_length($max_line_length);
+    $self->max_header_lines($max_header_lines);
+
+    ${*$self}{'http_buf'} = "";
+
+    return $self;
+}
+
+sub http_default_port {
+    80;
+}
+
+# set up property accessors
+for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) {
+    my $prop_name = "http_" . $method;
+    no strict 'refs';
+    *$method = sub {
+	my $self = shift;
+	my $old = ${*$self}{$prop_name};
+	${*$self}{$prop_name} = shift if @_;
+	return $old;
+    };
+}
+
+# we want this one to be a bit smarter
+sub http_version {
+    my $self = shift;
+    my $old = ${*$self}{'http_version'};
+    if (@_) {
+	my $v = shift;
+	$v = "1.0" if $v eq "1";  # float
+	unless ($v eq "1.0" or $v eq "1.1") {
+	    require Carp;
+	    Carp::croak("Unsupported HTTP version '$v'");
+	}
+	${*$self}{'http_version'} = $v;
+    }
+    $old;
+}
+
+sub format_request {
+    my $self = shift;
+    my $method = shift;
+    my $uri = shift;
+
+    my $content = (@_ % 2) ? pop : "";
+
+    for ($method, $uri) {
+	require Carp;
+	Carp::croak("Bad method or uri") if /\s/ || !length;
+    }
+
+    push(@{${*$self}{'http_request_method'}}, $method);
+    my $ver = ${*$self}{'http_version'};
+    my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0";
+
+    my @h;
+    my @connection;
+    my %given = (host => 0, "content-length" => 0, "te" => 0);
+    while (@_) {
+	my($k, $v) = splice(@_, 0, 2);
+	my $lc_k = lc($k);
+	if ($lc_k eq "connection") {
+	    $v =~ s/^\s+//;
+	    $v =~ s/\s+$//;
+	    push(@connection, split(/\s*,\s*/, $v));
+	    next;
+	}
+	if (exists $given{$lc_k}) {
+	    $given{$lc_k}++;
+	}
+	push(@h, "$k: $v");
+    }
+
+    if (length($content) && !$given{'content-length'}) {
+	push(@h, "Content-Length: " . length($content));
+    }
+
+    my @h2;
+    if ($given{te}) {
+	push(@connection, "TE") unless grep lc($_) eq "te", @connection;
+    }
+    elsif ($self->send_te && gunzip_ok()) {
+	# gzip is less wanted since the IO::Uncompress::Gunzip interface for
+	# it does not really allow chunked decoding to take place easily.
+	push(@h2, "TE: deflate,gzip;q=0.3");
+	push(@connection, "TE");
+    }
+
+    unless (grep lc($_) eq "close", @connection) {
+	if ($self->keep_alive) {
+	    if ($peer_ver eq "1.0") {
+		# from looking at Netscape's headers
+		push(@h2, "Keep-Alive: 300");
+		unshift(@connection, "Keep-Alive");
+	    }
+	}
+	else {
+	    push(@connection, "close") if $ver ge "1.1";
+	}
+    }
+    push(@h2, "Connection: " . join(", ", @connection)) if @connection;
+    unless ($given{host}) {
+	my $h = ${*$self}{'http_host'};
+	push(@h2, "Host: $h") if $h;
+    }
+
+    return _bytes(join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content));
+}
+
+
+sub write_request {
+    my $self = shift;
+    $self->print($self->format_request(@_));
+}
+
+sub format_chunk {
+    my $self = shift;
+    return $_[0] unless defined($_[0]) && length($_[0]);
+    return _bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF);
+}
+
+sub write_chunk {
+    my $self = shift;
+    return 1 unless defined($_[0]) && length($_[0]);
+    $self->print(_bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF));
+}
+
+sub format_chunk_eof {
+    my $self = shift;
+    my @h;
+    while (@_) {
+	push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2));
+    }
+    return _bytes(join("", "0$CRLF", @h, $CRLF));
+}
+
+sub write_chunk_eof {
+    my $self = shift;
+    $self->print($self->format_chunk_eof(@_));
+}
+
+
+sub my_read {
+    die if @_ > 3;
+    my $self = shift;
+    my $len = $_[1];
+    for (${*$self}{'http_buf'}) {
+	if (length) {
+	    $_[0] = substr($_, 0, $len, "");
+	    return length($_[0]);
+	}
+	else {
+	    die "read timeout" unless $self->can_read;
+	    return $self->sysread($_[0], $len);
+	}
+    }
+}
+
+
+sub my_readline {
+    my $self = shift;
+    my $what = shift;
+    for (${*$self}{'http_buf'}) {
+	my $max_line_length = ${*$self}{'http_max_line_length'};
+	my $pos;
+	while (1) {
+	    # find line ending
+	    $pos = index($_, "\012");
+	    last if $pos >= 0;
+	    die "$what line too long (limit is $max_line_length)"
+		if $max_line_length && length($_) > $max_line_length;
+
+	    # need to read more data to find a line ending
+            my $new_bytes = 0;
+
+          READ:
+            {   # wait until bytes start arriving
+                $self->can_read
+                     or die "read timeout";
+
+                # consume all incoming bytes
+                my $bytes_read = $self->sysread($_, 1024, length);
+                if(defined $bytes_read) {
+                    $new_bytes += $bytes_read;
+                }
+                elsif($!{EINTR} || $!{EAGAIN} || $!{EWOULDBLOCK}) {
+                    redo READ;
+                }
+                else {
+                    # if we have already accumulated some data let's at
+                    # least return that as a line
+                    length or die "$what read failed: $!";
+                }
+
+                # no line-ending, no new bytes
+                return length($_) ? substr($_, 0, length($_), "") : undef
+                    if $new_bytes==0;
+            }
+	}
+	die "$what line too long ($pos; limit is $max_line_length)"
+	    if $max_line_length && $pos > $max_line_length;
+
+	my $line = substr($_, 0, $pos+1, "");
+	$line =~ s/(\015?\012)\z// || die "Assert";
+	return wantarray ? ($line, $1) : $line;
+    }
+}
+
+
+sub can_read {
+    my $self = shift;
+    return 1 unless defined(fileno($self));
+    return 1 if $self->isa('IO::Socket::SSL') && $self->pending;
+    return 1 if $self->isa('Net::SSL') && $self->can('pending') && $self->pending;
+
+    # With no timeout, wait forever.  An explicit timeout of 0 can be
+    # used to just check if the socket is readable without waiting.
+    my $timeout = @_ ? shift : (${*$self}{io_socket_timeout} || undef);
+
+    my $fbits = '';
+    vec($fbits, fileno($self), 1) = 1;
+  SELECT:
+    {
+        my $before;
+        $before = time if $timeout;
+        my $nfound = select($fbits, undef, undef, $timeout);
+        if ($nfound < 0) {
+            if ($!{EINTR} || $!{EAGAIN} || $!{EWOULDBLOCK}) {
+                # don't really think EAGAIN/EWOULDBLOCK can happen here
+                if ($timeout) {
+                    $timeout -= time - $before;
+                    $timeout = 0 if $timeout < 0;
+                }
+                redo SELECT;
+            }
+            die "select failed: $!";
+        }
+        return $nfound > 0;
+    }
+}
+
+
+sub _rbuf {
+    my $self = shift;
+    if (@_) {
+	for (${*$self}{'http_buf'}) {
+	    my $old;
+	    $old = $_ if defined wantarray;
+	    $_ = shift;
+	    return $old;
+	}
+    }
+    else {
+	return ${*$self}{'http_buf'};
+    }
+}
+
+sub _rbuf_length {
+    my $self = shift;
+    return length ${*$self}{'http_buf'};
+}
+
+
+sub _read_header_lines {
+    my $self = shift;
+    my $junk_out = shift;
+
+    my @headers;
+    my $line_count = 0;
+    my $max_header_lines = ${*$self}{'http_max_header_lines'};
+    while (my $line = my_readline($self, 'Header')) {
+	if ($line =~ /^(\S+?)\s*:\s*(.*)/s) {
+	    push(@headers, $1, $2);
+	}
+	elsif (@headers && $line =~ s/^\s+//) {
+	    $headers[-1] .= " " . $line;
+	}
+	elsif ($junk_out) {
+	    push(@$junk_out, $line);
+	}
+	else {
+	    die "Bad header: '$line'\n";
+	}
+	if ($max_header_lines) {
+	    $line_count++;
+	    if ($line_count >= $max_header_lines) {
+		die "Too many header lines (limit is $max_header_lines)";
+	    }
+	}
+    }
+    return @headers;
+}
+
+
+sub read_response_headers {
+    my($self, %opt) = @_;
+    my $laxed = $opt{laxed};
+
+    my($status, $eol) = my_readline($self, 'Status');
+    unless (defined $status) {
+	die "Server closed connection without sending any data back";
+    }
+
+    my($peer_ver, $code, $message) = split(/\s+/, $status, 3);
+    if (!$peer_ver || $peer_ver !~ s,^HTTP/,, || $code !~ /^[1-5]\d\d$/) {
+	die "Bad response status line: '$status'" unless $laxed;
+	# assume HTTP/0.9
+	${*$self}{'http_peer_http_version'} = "0.9";
+	${*$self}{'http_status'} = "200";
+	substr(${*$self}{'http_buf'}, 0, 0) = $status . ($eol || "");
+	return 200 unless wantarray;
+	return (200, "Assumed OK");
+    };
+
+    ${*$self}{'http_peer_http_version'} = $peer_ver;
+    ${*$self}{'http_status'} = $code;
+
+    my $junk_out;
+    if ($laxed) {
+	$junk_out = $opt{junk_out} || [];
+    }
+    my @headers = $self->_read_header_lines($junk_out);
+
+    # pick out headers that read_entity_body might need
+    my @te;
+    my $content_length;
+    for (my $i = 0; $i < @headers; $i += 2) {
+	my $h = lc($headers[$i]);
+	if ($h eq 'transfer-encoding') {
+	    my $te = $headers[$i+1];
+	    $te =~ s/^\s+//;
+	    $te =~ s/\s+$//;
+	    push(@te, $te) if length($te);
+	}
+	elsif ($h eq 'content-length') {
+	    # ignore bogus and overflow values
+	    if ($headers[$i+1] =~ /^\s*(\d{1,15})(?:\s|$)/) {
+		$content_length = $1;
+	    }
+	}
+    }
+    ${*$self}{'http_te'} = join(",", @te);
+    ${*$self}{'http_content_length'} = $content_length;
+    ${*$self}{'http_first_body'}++;
+    delete ${*$self}{'http_trailers'};
+    return $code unless wantarray;
+    return ($code, $message, @headers);
+}
+
+
+sub read_entity_body {
+    my $self = shift;
+    my $buf_ref = \$_[0];
+    my $size = $_[1];
+    die "Offset not supported yet" if $_[2];
+
+    my $chunked;
+    my $bytes;
+
+    if (${*$self}{'http_first_body'}) {
+	${*$self}{'http_first_body'} = 0;
+	delete ${*$self}{'http_chunked'};
+	delete ${*$self}{'http_bytes'};
+	my $method = shift(@{${*$self}{'http_request_method'}});
+	my $status = ${*$self}{'http_status'};
+	if ($method eq "HEAD") {
+	    # this response is always empty regardless of other headers
+	    $bytes = 0;
+	}
+	elsif (my $te = ${*$self}{'http_te'}) {
+	    my @te = split(/\s*,\s*/, lc($te));
+	    die "Chunked must be last Transfer-Encoding '$te'"
+		unless pop(@te) eq "chunked";
+	    pop(@te) while @te && $te[-1] eq "chunked";  # ignore repeated chunked spec
+
+	    for (@te) {
+		if ($_ eq "deflate" && inflate_ok()) {
+		    #require Compress::Raw::Zlib;
+		    my ($i, $status) = Compress::Raw::Zlib::Inflate->new();
+		    die "Can't make inflator: $status" unless $i;
+		    $_ = sub { my $out; $i->inflate($_[0], \$out); $out }
+		}
+		elsif ($_ eq "gzip" && gunzip_ok()) {
+		    #require IO::Uncompress::Gunzip;
+		    my @buf;
+		    $_ = sub {
+			push(@buf, $_[0]);
+			return "" unless $_[1];
+			my $input = join("", @buf);
+			my $output;
+			IO::Uncompress::Gunzip::gunzip(\$input, \$output, Transparent => 0)
+			    or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
+			return \$output;
+		    };
+		}
+		elsif ($_ eq "identity") {
+		    $_ = sub { $_[0] };
+		}
+		else {
+		    die "Can't handle transfer encoding '$te'";
+		}
+	    }
+
+	    @te = reverse(@te);
+
+	    ${*$self}{'http_te2'} = @te ? \@te : "";
+	    $chunked = -1;
+	}
+	elsif (defined(my $content_length = ${*$self}{'http_content_length'})) {
+	    $bytes = $content_length;
+	}
+        elsif ($status =~ /^(?:1|[23]04)/) {
+            # RFC 2616 says that these responses should always be empty
+            # but that does not appear to be true in practice [RT#17907]
+            $bytes = 0;
+        }
+	else {
+	    # XXX Multi-Part types are self delimiting, but RFC 2616 says we
+	    # only has to deal with 'multipart/byteranges'
+
+	    # Read until EOF
+	}
+    }
+    else {
+	$chunked = ${*$self}{'http_chunked'};
+	$bytes   = ${*$self}{'http_bytes'};
+    }
+
+    if (defined $chunked) {
+	# The state encoded in $chunked is:
+	#   $chunked == 0:   read CRLF after chunk, then chunk header
+        #   $chunked == -1:  read chunk header
+	#   $chunked > 0:    bytes left in current chunk to read
+
+	if ($chunked <= 0) {
+	    my $line = my_readline($self, 'Entity body');
+	    if ($chunked == 0) {
+		die "Missing newline after chunk data: '$line'"
+		    if !defined($line) || $line ne "";
+		$line = my_readline($self, 'Entity body');
+	    }
+	    die "EOF when chunk header expected" unless defined($line);
+	    my $chunk_len = $line;
+	    $chunk_len =~ s/;.*//;  # ignore potential chunk parameters
+	    unless ($chunk_len =~ /^([\da-fA-F]+)\s*$/) {
+		die "Bad chunk-size in HTTP response: $line";
+	    }
+	    $chunked = hex($1);
+	    ${*$self}{'http_chunked'} = $chunked;
+	    if ($chunked == 0) {
+		${*$self}{'http_trailers'} = [$self->_read_header_lines];
+		$$buf_ref = "";
+
+		my $n = 0;
+		if (my $transforms = delete ${*$self}{'http_te2'}) {
+		    for (@$transforms) {
+			$$buf_ref = &$_($$buf_ref, 1);
+		    }
+		    $n = length($$buf_ref);
+		}
+
+		# in case somebody tries to read more, make sure we continue
+		# to return EOF
+		delete ${*$self}{'http_chunked'};
+		${*$self}{'http_bytes'} = 0;
+
+		return $n;
+	    }
+	}
+
+	my $n = $chunked;
+	$n = $size if $size && $size < $n;
+	$n = my_read($self, $$buf_ref, $n);
+	return undef unless defined $n;
+
+	${*$self}{'http_chunked'} = $chunked - $n;
+
+	if ($n > 0) {
+	    if (my $transforms = ${*$self}{'http_te2'}) {
+		for (@$transforms) {
+		    $$buf_ref = &$_($$buf_ref, 0);
+		}
+		$n = length($$buf_ref);
+		$n = -1 if $n == 0;
+	    }
+	}
+	return $n;
+    }
+    elsif (defined $bytes) {
+	unless ($bytes) {
+	    $$buf_ref = "";
+	    return 0;
+	}
+	my $n = $bytes;
+	$n = $size if $size && $size < $n;
+	$n = my_read($self, $$buf_ref, $n);
+	${*$self}{'http_bytes'} = defined $n ? $bytes - $n : $bytes;
+	return $n;
+    }
+    else {
+	# read until eof
+	$size ||= 8*1024;
+	return my_read($self, $$buf_ref, $size);
+    }
+}
+
+sub get_trailers {
+    my $self = shift;
+    @{${*$self}{'http_trailers'} || []};
+}
+
+BEGIN {
+my $gunzip_ok;
+my $inflate_ok;
+
+sub gunzip_ok {
+    return $gunzip_ok if defined $gunzip_ok;
+
+    # Try to load IO::Uncompress::Gunzip.
+    local $@;
+    local $SIG{__DIE__};
+    $gunzip_ok = 0;
+
+    eval {
+	require IO::Uncompress::Gunzip;
+	$gunzip_ok++;
+    };
+
+    return $gunzip_ok;
+}
+
+sub inflate_ok {
+    return $inflate_ok if defined $inflate_ok;
+
+    # Try to load Compress::Raw::Zlib.
+    local $@;
+    local $SIG{__DIE__};
+    $inflate_ok = 0;
+
+    eval {
+	require Compress::Raw::Zlib;
+	$inflate_ok++;
+    };
+
+    return $inflate_ok;
+}
+
+} # BEGIN
+
+1;
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Net::HTTP::Methods - Methods shared by Net::HTTP and Net::HTTPS
+
+=head1 VERSION
+
+version 6.17
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@activestate.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2001-2017 by Gisle Aas.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
+
+__END__
+
+# ABSTRACT: Methods shared by Net::HTTP and Net::HTTPS

Perl OTRS/Kernel/cpan-lib/Net/HTTP/NB.pm

@@ -0,0 +1,121 @@
+package Net::HTTP::NB;
+$Net::HTTP::NB::VERSION = '6.17';
+use strict;
+use warnings;
+
+use base 'Net::HTTP';
+
+sub can_read {
+    return 1;
+}
+
+sub sysread {
+    my $self = $_[0];
+    if (${*$self}{'httpnb_read_count'}++) {
+	${*$self}{'http_buf'} = ${*$self}{'httpnb_save'};
+	die "Multi-read\n";
+    }
+    my $buf;
+    my $offset = $_[3] || 0;
+    my $n = sysread($self, $_[1], $_[2], $offset);
+    ${*$self}{'httpnb_save'} .= substr($_[1], $offset);
+    return $n;
+}
+
+sub read_response_headers {
+    my $self = shift;
+    ${*$self}{'httpnb_read_count'} = 0;
+    ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
+    my @h = eval { $self->SUPER::read_response_headers(@_) };
+    if ($@) {
+	return if $@ eq "Multi-read\n";
+	die;
+    }
+    return @h;
+}
+
+sub read_entity_body {
+    my $self = shift;
+    ${*$self}{'httpnb_read_count'} = 0;
+    ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
+    # XXX I'm not so sure this does the correct thing in case of
+    # transfer-encoding transforms
+    my $n = eval { $self->SUPER::read_entity_body(@_); };
+    if ($@) {
+	$_[0] = "";
+	return -1;
+    }
+    return $n;
+}
+
+1;
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Net::HTTP::NB - Non-blocking HTTP client
+
+=head1 VERSION
+
+version 6.17
+
+=head1 SYNOPSIS
+
+ use Net::HTTP::NB;
+ my $s = Net::HTTP::NB->new(Host => "www.perl.com") || die $@;
+ $s->write_request(GET => "/");
+
+ use IO::Select;
+ my $sel = IO::Select->new($s);
+
+ READ_HEADER: {
+    die "Header timeout" unless $sel->can_read(10);
+    my($code, $mess, %h) = $s->read_response_headers;
+    redo READ_HEADER unless $code;
+ }
+
+ while (1) {
+    die "Body timeout" unless $sel->can_read(10);
+    my $buf;
+    my $n = $s->read_entity_body($buf, 1024);
+    last unless $n;
+    print $buf;
+ }
+
+=head1 DESCRIPTION
+
+Same interface as C<Net::HTTP> but it will never try multiple reads
+when the read_response_headers() or read_entity_body() methods are
+invoked.  This make it possible to multiplex multiple Net::HTTP::NB
+using select without risk blocking.
+
+If read_response_headers() did not see enough data to complete the
+headers an empty list is returned.
+
+If read_entity_body() did not see new entity data in its read
+the value -1 is returned.
+
+=head1 SEE ALSO
+
+L<Net::HTTP>
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@activestate.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2001-2017 by Gisle Aas.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
+
+__END__
+
+#ABSTRACT: Non-blocking HTTP client
+

Perl OTRS/Kernel/cpan-lib/Net/HTTPS.pm

@@ -0,0 +1,135 @@
+package Net::HTTPS;
+$Net::HTTPS::VERSION = '6.17';
+use strict;
+use warnings;
+
+# Figure out which SSL implementation to use
+use vars qw($SSL_SOCKET_CLASS);
+if ($SSL_SOCKET_CLASS) {
+    # somebody already set it
+}
+elsif ($SSL_SOCKET_CLASS = $ENV{PERL_NET_HTTPS_SSL_SOCKET_CLASS}) {
+    unless ($SSL_SOCKET_CLASS =~ /^(IO::Socket::SSL|Net::SSL)\z/) {
+	die "Bad socket class [$SSL_SOCKET_CLASS]";
+    }
+    eval "require $SSL_SOCKET_CLASS";
+    die $@ if $@;
+}
+elsif ($IO::Socket::SSL::VERSION) {
+    $SSL_SOCKET_CLASS = "IO::Socket::SSL"; # it was already loaded
+}
+elsif ($Net::SSL::VERSION) {
+    $SSL_SOCKET_CLASS = "Net::SSL";
+}
+else {
+    eval { require IO::Socket::SSL; };
+    if ($@) {
+	my $old_errsv = $@;
+	eval {
+	    require Net::SSL;  # from Crypt-SSLeay
+	};
+	if ($@) {
+	    $old_errsv =~ s/\s\(\@INC contains:.*\)/)/g;
+	    die $old_errsv . $@;
+	}
+	$SSL_SOCKET_CLASS = "Net::SSL";
+    }
+    else {
+	$SSL_SOCKET_CLASS = "IO::Socket::SSL";
+    }
+}
+
+require Net::HTTP::Methods;
+
+our @ISA=($SSL_SOCKET_CLASS, 'Net::HTTP::Methods');
+
+sub configure {
+    my($self, $cnf) = @_;
+    $self->http_configure($cnf);
+}
+
+sub http_connect {
+    my($self, $cnf) = @_;
+    if ($self->isa("Net::SSL")) {
+	if ($cnf->{SSL_verify_mode}) {
+	    if (my $f = $cnf->{SSL_ca_file}) {
+		$ENV{HTTPS_CA_FILE} = $f;
+	    }
+	    if (my $f = $cnf->{SSL_ca_path}) {
+		$ENV{HTTPS_CA_DIR} = $f;
+	    }
+	}
+	if ($cnf->{SSL_verifycn_scheme}) {
+	    $@ = "Net::SSL from Crypt-SSLeay can't verify hostnames; either install IO::Socket::SSL or turn off verification by setting the PERL_LWP_SSL_VERIFY_HOSTNAME environment variable to 0";
+	    return undef;
+	}
+    }
+    $self->SUPER::configure($cnf);
+}
+
+sub http_default_port {
+    443;
+}
+
+if ($SSL_SOCKET_CLASS eq "Net::SSL") {
+    # The underlying SSLeay classes fails to work if the socket is
+    # placed in non-blocking mode.  This override of the blocking
+    # method makes sure it stays the way it was created.
+    *blocking = sub { };
+}
+
+1;
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Net::HTTPS - Low-level HTTP over SSL/TLS connection (client)
+
+=head1 VERSION
+
+version 6.17
+
+=head1 DESCRIPTION
+
+The C<Net::HTTPS> is a low-level HTTP over SSL/TLS client.  The interface is the same
+as the interface for C<Net::HTTP>, but the constructor takes additional parameters
+as accepted by L<IO::Socket::SSL>.  The C<Net::HTTPS> object is an C<IO::Socket::SSL>
+too, which makes it inherit additional methods from that base class.
+
+For historical reasons this module also supports using C<Net::SSL> (from the
+Crypt-SSLeay distribution) as its SSL driver and base class.  This base is
+automatically selected if available and C<IO::Socket::SSL> isn't.  You might
+also force which implementation to use by setting $Net::HTTPS::SSL_SOCKET_CLASS
+before loading this module.  If not set this variable is initialized from the
+C<PERL_NET_HTTPS_SSL_SOCKET_CLASS> environment variable.
+
+=head1 ENVIRONMENT
+
+You might set the C<PERL_NET_HTTPS_SSL_SOCKET_CLASS> environment variable to the name
+of the base SSL implementation (and Net::HTTPS base class) to use.  The default
+is C<IO::Socket::SSL>.  Currently the only other supported value is C<Net::SSL>.
+
+=head1 SEE ALSO
+
+L<Net::HTTP>, L<IO::Socket::SSL>
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@activestate.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2001-2017 by Gisle Aas.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
+
+__END__
+
+#ABSTRACT: Low-level HTTP over SSL/TLS connection (client)
+

Perl OTRS/Kernel/cpan-lib/Net/IMAP/Simple/PipeSocket.pm

@@ -0,0 +1,132 @@
+package Net::IMAP::Simple::PipeSocket;
+
+use strict;
+use warnings;
+use Carp;
+use IPC::Open3;
+use IO::Select;
+use Symbol 'gensym';
+use base 'Tie::Handle';
+
+sub new {
+    my $class = shift;
+    my %args  = @_;
+
+    croak "command (e.g. 'ssh hostname dovecot') argument required" unless $args{cmd};
+
+    open my $fake, "+>", undef or die "initernal error dealing with blarg: $!"; ## no critic
+
+    my($wtr, $rdr, $err); $err = gensym;
+    my $pid = eval { open3($wtr, $rdr, $err, $args{cmd}) } or croak $@;
+    my $sel = IO::Select->new($err);
+
+    # my $orig = select $wtr; $|=1;
+    # select $rdr; $|=1;
+    # select $orig;
+
+    my $this = tie *{$fake}, $class,
+        (%args, pid=>$pid, wtr=>$wtr, rdr=>$rdr, err=>$err, sel=>$sel, )
+            or croak $!;
+
+    return $fake;
+}
+
+sub UNTIE   { return $_[0]->_waitpid }
+sub DESTROY { return $_[0]->_waitpid }
+
+sub FILENO {
+    my $this = shift;
+    my $rdr  = $this->{rdr};
+
+    # do we mean rdr or wtr? meh?
+    return fileno($rdr); # probably need this for select() on the read handle
+}
+
+sub TIEHANDLE {
+    my $class = shift;
+    my $this  = bless {@_}, $class;
+
+    return $this;
+}
+
+sub _chkerr {
+    my $this = shift;
+    my $sel = $this->{sel};
+
+    while( my @rdy = $sel->can_read(0) ) {
+        for my $fh (@rdy) {
+            if( eof($fh) ) {
+                $sel->remove($fh);
+                next;
+            }
+            my $line = <$fh>;
+            warn "PIPE ERR: $line";
+        }
+    }
+
+    return
+}
+
+sub PRINT {
+    my $this = shift;
+    my $wtr  = $this->{wtr};
+
+    $this->_chkerr;
+    return print $wtr @_;
+}
+
+sub READLINE {
+    my $this = shift;
+    my $rdr  = $this->{rdr};
+
+    $this->_chkerr;
+    my $line = <$rdr>;
+    return $line;
+}
+
+sub _waitpid {
+    my $this = shift;
+
+    if( my $pid = delete $this->{pid} ) {
+        for my $key (qw(wtr rdr err)) {
+            close delete $this->{$key} if exists $this->{$key};
+        }
+
+        kill 1, $pid;
+        # doesn't really matter if this works... we hung up all the
+        # filehandles, so ... it's probably dead anyway.
+
+        waitpid( $pid, 0 );
+        my $child_exit_status = $? >> 8;
+        return $child_exit_status;
+    }
+
+    return;
+}
+
+sub CLOSE {
+    my $this = shift;
+    my $rdr  = $this->{rdr};
+    my $wtr  = $this->{wtr};
+
+    close $rdr or warn "PIPE ERR (close-r): $!";
+    close $wtr or warn "PIPE ERR (close-w): $!";
+
+    return;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::IMAP::Simple::PipeSocket - a little wrapper around IPC-Open3 that feels like a socket
+
+=head1 SYNOPSIS
+
+This module is really just a wrapper around IPC-Open3 that can be dropped in
+place of a socket handle.  The L<Net::IMAP::Simple> code assumes the socket is
+always a socket and is never a pipe and re-writing it all would be horrible.
+
+This abstraction is used only for that purpose.

Perl OTRS/Kernel/cpan-lib/Net/SSLGlue.pm

@@ -0,0 +1,42 @@
+package Net::SSLGlue;
+our $VERSION = '1.058';
+
+=head1 NAME
+
+Net::SSLGlue - add/extend SSL support for common perl modules
+
+=head1 DESCRIPTION
+
+Some commonly used perl modules don't have SSL support at all, even if the
+protocol supports it. Others have SSL support, but most of them don't do
+proper checking of the server's certificate.
+
+The C<Net::SSLGlue::*> modules try to add SSL support or proper certificate
+checking to these modules. Currently support for the following modules is
+available:
+
+=over 4
+
+=item Net::SMTP - add SSL from beginning or using STARTTLS
+
+=item Net::POP3 - add SSL from beginning or using STLS
+
+=item Net::FTP  - add SSL and IPv6 support to Net::FTP
+
+=item Net::LDAP - add proper certificate checking
+
+=item LWP - add proper certificate checking for older LWP versions
+
+=back
+
+There is also a Net::SSLGlue::Socket package which combines ssl and non-ssl
+and ipv6 capabilities to make it easier to enhance modules based on
+IO::Socket::INET.
+
+=head1 COPYRIGHT
+
+This module and the modules in the Net::SSLGlue Hierarchy distributed together
+with this module are copyright (c) 2008-2015, Steffen Ullrich.
+All Rights Reserved.
+These modules are free software. They may be used, redistributed and/or modified
+under the same terms as Perl itself.

Perl OTRS/Kernel/cpan-lib/Net/SSLGlue/POP3.pm

@@ -0,0 +1,222 @@
+use strict;
+use warnings;
+
+package Net::SSLGlue::POP3;
+use IO::Socket::SSL 1.19;
+use Net::POP3;
+our $VERSION = 0.911;
+
+my $DONT;
+BEGIN {
+    if (defined &Net::POP3::starttls) {
+	warn "using SSL support of Net::POP3 $Net::POP3::VERSION instead of SSLGlue";
+	$DONT = 1;
+	goto DONE;
+    }
+
+    ##############################################################################
+    # mix starttls method into Net::POP3 which on SSL handshake success
+    # upgrades the class to Net::SSLGlue::POP3::_SSLified
+    ##############################################################################
+    *Net::POP3::starttls = sub {
+	my $self = shift;
+	$self->_STLS or return;
+	my $host = $self->host;
+	# for name verification strip port from domain:port, ipv4:port, [ipv6]:port
+	$host =~s{(?<!:):\d+$}{};
+
+	Net::SSLGlue::POP3::_SSLified->start_SSL( $self,
+	    SSL_verify_mode => 1,
+	    SSL_verifycn_scheme => 'pop3',
+	    SSL_verifycn_name => $host,
+	    @_
+	) or return;
+    };
+
+    *Net::POP3::_STLS = sub {
+	shift->command("STLS")->response() == Net::POP3::CMD_OK
+    };
+
+    no warnings 'redefine';
+    my $old_new = \&Net::POP3::new;
+    *Net::POP3::new = sub {
+	my $class = shift;
+	my %arg = @_ % 2 == 0 ? @_ : ( Host => shift,@_ );
+	if ( delete $arg{SSL} ) {
+	    $arg{Port} ||= 995;
+	    return Net::SSLGlue::POP3::_SSLified->new(%arg);
+	} else {
+	    return $old_new->($class,%arg);
+	}
+    };
+
+    DONE:
+    1;
+}
+
+##############################################################################
+# Socket class derived from IO::Socket::SSL
+# strict certificate verification per default
+##############################################################################
+our %SSLopts;
+{
+    package Net::SSLGlue::POP3::_SSL_Socket;
+    goto DONE if $DONT;
+    our @ISA = 'IO::Socket::SSL';
+    *configure_SSL = sub {
+	my ($self,$arg_hash) = @_;
+
+	# set per default strict certificate verification
+	$arg_hash->{SSL_verify_mode} = 1
+	    if ! exists $arg_hash->{SSL_verify_mode};
+	$arg_hash->{SSL_verifycn_scheme} = 'pop3'
+	    if ! exists $arg_hash->{SSL_verifycn_scheme};
+	$arg_hash->{SSL_verifycn_name} = $self->host
+	    if ! exists $arg_hash->{SSL_verifycn_name};
+
+	# force keys from %SSLopts
+	while ( my ($k,$v) = each %SSLopts ) {
+	    $arg_hash->{$k} = $v;
+	}
+	return $self->SUPER::configure_SSL($arg_hash)
+    };
+
+    DONE:
+    1;
+}
+
+
+##############################################################################
+# Net::POP3 derived from Net::POP3::_SSL_Socket instead of IO::Socket::INET
+# this talks SSL to the peer
+##############################################################################
+{
+    package Net::SSLGlue::POP3::_SSLified;
+    use Carp 'croak';
+    goto DONE if $DONT;
+
+    # deriving does not work because we need to replace a superclass
+    # from Net::POP3, so just copy the class into the new one and then
+    # change it
+
+    # copy subs
+    for ( keys %{Net::POP3::} ) {
+	no strict 'refs';
+	*{$_} = \&{ "Net::POP3::$_" } if defined &{ "Net::POP3::$_" };
+    }
+
+    # copy + fix @ISA
+    our @ISA = @Net::POP3::ISA;
+    grep { s{^IO::Socket::INET$}{Net::SSLGlue::POP3::_SSL_Socket} } @ISA
+	or die "cannot find and replace IO::Socket::INET superclass";
+
+    # we are already sslified
+    no warnings 'redefine';
+    *starttls = sub { croak "have already TLS\n" };
+
+    my $old_new = \&new;
+    *new = sub {
+	my $class = shift;
+	my %arg = @_ % 2 == 0 ? @_ : ( Host => shift,@_ );
+	local %SSLopts;
+	$SSLopts{$_} = delete $arg{$_} for ( grep { /^SSL_/ } keys %arg );
+	return $old_new->($class,%arg);
+    };
+
+    # Net::Cmd getline uses select, but this is not sufficient with SSL
+    # note that this does no EBCDIC etc conversions
+    *getline = sub {
+	my $self = shift;
+	# skip Net::POP3 getline and go directly to IO::Socket::SSL
+	return $self->IO::Socket::SSL::getline(@_);
+    };
+
+    DONE:
+    1;
+}
+
+1;
+
+=head1 NAME
+
+Net::SSLGlue::POP3 - make Net::POP3 able to use SSL
+
+=head1 SYNOPSIS
+
+    use Net::SSLGlue::POP3;
+    my $pop3s = Net::POP3->new( $host,
+	SSL => 1,
+	SSL_ca_path => ...
+    );
+
+    my $pop3 = Net::POP3->new( $host );
+    $pop3->starttls( SSL_ca_path => ... );
+
+=head1 DESCRIPTION
+
+L<Net::SSLGlue::POP3> extends L<Net::POP3> so one can either start directly with SSL
+or switch later to SSL using the STLS command.
+
+By default it will take care to verify the certificate according to the rules
+for POP3 implemented in L<IO::Socket::SSL>.
+
+=head1 METHODS
+
+=over 4
+
+=item new
+
+The method C<new> of L<Net::POP3> is now able to start directly with SSL when
+the argument C<<SSL => 1>> is given. In this case it will not create an
+L<IO::Socket::INET> object but an L<IO::Socket::SSL> object. One can give the
+usual C<SSL_*> parameter of L<IO::Socket::SSL> to C<Net::POP3::new>.
+
+=item starttls
+
+If the connection is not yet SSLified it will issue the STLS command and
+change the object, so that SSL will now be used. The usual C<SSL_*> parameter of
+L<IO::Socket::SSL> will be given.
+
+=item peer_certificate ...
+
+Once the SSL connection is established the object is derived from
+L<IO::Socket::SSL> so that you can use this method to get information about the
+certificate. See the L<IO::Socket::SSL> documentation.
+
+=back
+
+All of these methods can take the C<SSL_*> parameter from L<IO::Socket::SSL> to
+change the behavior of the SSL connection. The following parameters are
+especially useful:
+
+=over 4
+
+=item SSL_ca_path, SSL_ca_file
+
+Specifies the path or a file where the CAs used for checking the certificates
+are located. This is typically L</etc/ssl/certs> on UNIX systems.
+
+=item SSL_verify_mode
+
+If set to 0, verification of the certificate will be disabled. By default
+it is set to 1 which means that the peer certificate is checked.
+
+=item SSL_verifycn_name
+
+Usually the name given as the hostname in the constructor is used to verify the
+identity of the certificate. If you want to check the certificate against
+another name you can specify it with this parameter.
+
+=back
+
+=head1 SEE ALSO
+
+IO::Socket::SSL, Net::POP3
+
+=head1 COPYRIGHT
+
+This module is copyright (c) 2013, Steffen Ullrich.
+All Rights Reserved.
+This module is free software. It may be used, redistributed and/or modified
+under the same terms as Perl itself.
+

Perl OTRS/Kernel/cpan-lib/Net/SSLGlue/SMTP.pm

@@ -0,0 +1,224 @@
+use strict;
+use warnings;
+
+package Net::SSLGlue::SMTP;
+use IO::Socket::SSL 1.19;
+use Net::SMTP;
+our $VERSION = 1.001;
+
+my $DONT;
+BEGIN {
+    if (defined &Net::SMTP::starttls) {
+	warn "using SSL support of Net::SMTP $Net::SMTP::VERSION instead of SSLGlue";
+	$DONT = 1;
+	goto DONE;
+    }
+
+    ##############################################################################
+    # mix starttls method into Net::SMTP which on SSL handshake success
+    # upgrades the class to Net::SSLGlue::SMTP::_SSLified
+    ##############################################################################
+    *Net::SMTP::starttls = sub {
+	my $self = shift;
+	$self->_STARTTLS or return;
+	my $host = $self->host;
+	# for name verification strip port from domain:port, ipv4:port, [ipv6]:port
+	$host =~s{(?<!:):\d+$}{};
+
+	Net::SSLGlue::SMTP::_SSLified->start_SSL( $self,
+	    SSL_verify_mode => 1,
+	    SSL_verifycn_scheme => 'smtp',
+	    SSL_verifycn_name => $host,
+	    @_
+	) or return;
+
+	# another hello after starttls to read new ESMTP capabilities
+	return $self->hello(${*$self}{net_smtp_hello_domain});
+    };
+
+    *Net::SMTP::_STARTTLS = sub {
+	shift->command("STARTTLS")->response() == Net::SMTP::CMD_OK
+    };
+
+    no warnings 'redefine';
+    my $old_new = \&Net::SMTP::new;
+    *Net::SMTP::new = sub {
+	my $class = shift;
+	my %arg = @_ % 2 == 0 ? @_ : ( Host => shift,@_ );
+	if ( delete $arg{SSL} ) {
+	    $arg{Port} ||= 465;
+	    return Net::SSLGlue::SMTP::_SSLified->new(%arg);
+	} else {
+	    return $old_new->($class,%arg);
+	}
+    };
+
+    my $old_hello = \&Net::SMTP::hello;
+    *Net::SMTP::hello = sub {
+	my ($self,$domain) = @_;
+	${*$self}{net_smtp_hello_domain} = $domain if $domain;
+	goto &$old_hello;
+    };
+
+    DONE:
+    1;
+}
+
+##############################################################################
+# Socket class derived from IO::Socket::SSL
+# strict certificate verification per default
+##############################################################################
+our %SSLopts;
+{
+    package Net::SSLGlue::SMTP::_SSL_Socket;
+    goto DONE if $DONT;
+    our @ISA = 'IO::Socket::SSL';
+    *configure_SSL = sub {
+	my ($self,$arg_hash) = @_;
+
+	# set per default strict certificate verification
+	$arg_hash->{SSL_verify_mode} = 1
+	    if ! exists $arg_hash->{SSL_verify_mode};
+	$arg_hash->{SSL_verifycn_scheme} = 'smtp'
+	    if ! exists $arg_hash->{SSL_verifycn_scheme};
+	$arg_hash->{SSL_verifycn_name} = $self->host
+	    if ! exists $arg_hash->{SSL_verifycn_name};
+
+	# force keys from %SSLopts
+	while ( my ($k,$v) = each %SSLopts ) {
+	    $arg_hash->{$k} = $v;
+	}
+	return $self->SUPER::configure_SSL($arg_hash)
+    };
+
+    DONE:
+    1;
+}
+
+
+##############################################################################
+# Net::SMTP derived from Net::SSLGlue::SMTP::_SSL_Socket instead of IO::Socket::INET
+# this talks SSL to the peer
+##############################################################################
+{
+    package Net::SSLGlue::SMTP::_SSLified;
+    use Carp 'croak';
+    goto DONE if $DONT;
+
+    # deriving does not work because we need to replace a superclass
+    # from Net::SMTP, so just copy the class into the new one and then
+    # change it
+
+    # copy subs
+    for ( keys %{Net::SMTP::} ) {
+	no strict 'refs';
+	*{$_} = \&{ "Net::SMTP::$_" } if defined &{ "Net::SMTP::$_" };
+    }
+
+    # copy + fix @ISA
+    our @ISA = @Net::SMTP::ISA;
+    grep { s{^IO::Socket::INET$}{Net::SSLGlue::SMTP::_SSL_Socket} } @ISA
+	or die "cannot find and replace IO::Socket::INET superclass";
+
+    # we are already sslified
+    no warnings 'redefine';
+    *starttls = sub { croak "have already TLS\n" };
+
+    my $old_new = \&new;
+    *new = sub {
+	my $class = shift;
+	my %arg = @_ % 2 == 0 ? @_ : ( Host => shift,@_ );
+	local %SSLopts;
+	$SSLopts{$_} = delete $arg{$_} for ( grep { /^SSL_/ } keys %arg );
+	return $old_new->($class,%arg);
+    };
+
+    DONE:
+    1;
+}
+
+1;
+
+=head1 NAME
+
+Net::SSLGlue::SMTP - make Net::SMTP able to use SSL
+
+=head1 SYNOPSIS
+
+    use Net::SSLGlue::SMTP;
+    my $smtp_ssl = Net::SMTP->new( $host,
+	SSL => 1,
+	SSL_ca_path => ...
+    );
+
+    my $smtp_plain = Net::SMTP->new( $host );
+    $smtp_plain->starttls( SSL_ca_path => ... );
+
+=head1 DESCRIPTION
+
+L<Net::SSLGlue::SMTP> extends L<Net::SMTP> so one can either start directly with SSL
+or switch later to SSL using the STARTTLS command.
+
+By default it will take care to verify the certificate according to the rules
+for SMTP implemented in L<IO::Socket::SSL>.
+
+=head1 METHODS
+
+=over 4
+
+=item new
+
+The method C<new> of L<Net::SMTP> is now able to start directly with SSL when
+the argument C<<SSL => 1>> is given. In this case it will not create an
+L<IO::Socket::INET> object but an L<IO::Socket::SSL> object. One can give the
+usual C<SSL_*> parameter of L<IO::Socket::SSL> to C<Net::SMTP::new>.
+
+=item starttls
+
+If the connection is not yet SSLified it will issue the STARTTLS command and
+change the object, so that SSL will now be used. The usual C<SSL_*> parameter of
+L<IO::Socket::SSL> will be given.
+
+=item peer_certificate ...
+
+Once the SSL connection is established the object is derived from
+L<IO::Socket::SSL> so that you can use this method to get information about the
+certificate. See the L<IO::Socket::SSL> documentation.
+
+=back
+
+All of these methods can take the C<SSL_*> parameter from L<IO::Socket::SSL> to
+change the behavior of the SSL connection. The following parameters are
+especially useful:
+
+=over 4
+
+=item SSL_ca_path, SSL_ca_file
+
+Specifies the path or a file where the CAs used for checking the certificates
+are located. This is typically L</etc/ssl/certs> on UNIX systems.
+
+=item SSL_verify_mode
+
+If set to 0, verification of the certificate will be disabled. By default
+it is set to 1 which means that the peer certificate is checked.
+
+=item SSL_verifycn_name
+
+Usually the name given as the hostname in the constructor is used to verify the
+identity of the certificate. If you want to check the certificate against
+another name you can specify it with this parameter.
+
+=back
+
+=head1 SEE ALSO
+
+IO::Socket::SSL, Net::SMTP
+
+=head1 COPYRIGHT
+
+This module is copyright (c) 2008, Steffen Ullrich.
+All Rights Reserved.
+This module is free software. It may be used, redistributed and/or modified
+under the same terms as Perl itself.
+