r72123 - in /branches/upstream/libwww-perl/current: ./ lib/ lib/LWP/ lib/LWP/Protocol/ t/ t/live/

periapt-guest at users.alioth.debian.org periapt-guest at users.alioth.debian.org
Thu Mar 31 23:06:17 UTC 2011


Author: periapt-guest
Date: Thu Mar 31 23:06:07 2011
New Revision: 72123

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=72123
Log:
[svn-upgrade] new version libwww-perl (6.01)

Added:
    branches/upstream/libwww-perl/current/lib/LWP/Protocol/http10.pm
    branches/upstream/libwww-perl/current/lib/LWP/Protocol/https.pm
    branches/upstream/libwww-perl/current/lib/LWP/Protocol/https10.pm
    branches/upstream/libwww-perl/current/t/live/https.t
Modified:
    branches/upstream/libwww-perl/current/Changes
    branches/upstream/libwww-perl/current/MANIFEST
    branches/upstream/libwww-perl/current/META.yml
    branches/upstream/libwww-perl/current/Makefile.PL
    branches/upstream/libwww-perl/current/README
    branches/upstream/libwww-perl/current/README.SSL
    branches/upstream/libwww-perl/current/lib/LWP.pm
    branches/upstream/libwww-perl/current/lib/LWP/ConnCache.pm
    branches/upstream/libwww-perl/current/lib/LWP/UserAgent.pm
    branches/upstream/libwww-perl/current/t/TEST

Modified: branches/upstream/libwww-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/Changes?rev=72123&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/Changes (original)
+++ branches/upstream/libwww-perl/current/Changes Thu Mar 31 23:06:07 2011
@@ -1,29 +1,3 @@
-_______________________________________________________________________________
-2011-03-27  Release 6.02
-
-This is the release where we try to help the CPAN-toolchain be able to install
-the modules required for https-support in LWP.  We have done this by unbundling
-the LWP::Protocol::https module from the libwww-perl distribution.  In order to
-have https support you now need to install (or depend on) 'LWP::Protocol::https'
-and then this will make sure that all the prerequsite modules comes along.
-See [RT#66838].
-
-This release also removes the old http10 modules that has really been
-deprecated since v5.60.  These should have been removed at the v6.00 jump, but
-I forgot.
-
-
-Christopher J. Madsen (1):
-      Ignores env variables when ssl_opts provided [RT#66663]
-
-Gisle Aas (4):
-      Fix typo; Authen::NTLM [RT#66884]
-
-Yury Zavarin (1):
-      Support LWP::ConnCache->new(total_capacity => undef)
-
-
-
 _______________________________________________________________________________
 2011-03-09  Release 6.01
 

Modified: branches/upstream/libwww-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/MANIFEST?rev=72123&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/MANIFEST (original)
+++ branches/upstream/libwww-perl/current/MANIFEST Thu Mar 31 23:06:07 2011
@@ -25,6 +25,9 @@
 lib/LWP/Protocol/ftp.pm		Access with the FTP protocol
 lib/LWP/Protocol/gopher.pm	Access with the Gopher protocol
 lib/LWP/Protocol/http.pm	Access with HTTP/1.1 protocol
+lib/LWP/Protocol/http10.pm	Access with HTTP/1.0 protocol
+lib/LWP/Protocol/https.pm	Access with HTTP/1.1 protocol over SSL
+lib/LWP/Protocol/https10.pm	Access with HTTP/1.0 protocol over SSL
 lib/LWP/Protocol/loopback.pm    Returns request (like HTTP TRACE)
 lib/LWP/Protocol/mailto.pm	Allows you to POST mail using sendmail
 lib/LWP/Protocol/nntp.pm	Handles access to news: and nntp: URLs
@@ -38,6 +41,7 @@
 t/TEST				Run tests
 t/base/protocols.t		Test protocol methods of LWP::UserAgent
 t/base/ua.t			Basic LWP::UserAgent tests
+t/live/https.t
 t/live/jigsaw-auth-b.t
 t/live/jigsaw-auth-d.t
 t/live/jigsaw-chunk.t

Modified: branches/upstream/libwww-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/META.yml?rev=72123&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/META.yml (original)
+++ branches/upstream/libwww-perl/current/META.yml Thu Mar 31 23:06:07 2011
@@ -1,6 +1,6 @@
 --- #YAML:1.0
 name:               libwww-perl
-version:            6.02
+version:            6.01
 abstract:           The World-Wide Web library for Perl
 author:
     - Gisle Aas <gisle at activestate.com>
@@ -42,11 +42,13 @@
     directory:
         - t
         - inc
-generated_by:       ExtUtils::MakeMaker version 6.57_05
+generated_by:       ExtUtils::MakeMaker version 6.56
 meta-spec:
     url:      http://module-build.sourceforge.net/META-spec-v1.4.html
     version:  1.4
 recommends:
-    Authen::NTLM:         1.02
-    Data::Dump:           0
-    LWP::Protocol::https:  6.02
+    Authen::NTML:     2.12
+    Data::Dump:       0
+    IO::Socket::SSL:  1.38
+    Mozilla::CA:      20110101
+    Net::HTTPS:       6

Modified: branches/upstream/libwww-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/Makefile.PL?rev=72123&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/Makefile.PL (original)
+++ branches/upstream/libwww-perl/current/Makefile.PL Thu Mar 31 23:06:07 2011
@@ -66,8 +66,10 @@
     },
     META_MERGE => {
         recommends => {
-	    'LWP::Protocol::https' => '6.02',
-            'Authen::NTLM' => "1.02",
+	    'Net::HTTPS' => 6,
+            'IO::Socket::SSL' => "1.38",
+            'Mozilla::CA' => "20110101",
+            'Authen::NTML' => "2.12",
             'Data::Dump' => 0,
         },
 	resources => {

Modified: branches/upstream/libwww-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/README?rev=72123&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/README (original)
+++ branches/upstream/libwww-perl/current/README Thu Mar 31 23:06:07 2011
@@ -36,7 +36,8 @@
   WWW-RobotRules
 
 If you want to access sites using the https protocol, then you need to
-install the LWP::Protocol::https module from CPAN.
+install the IO::Socket::SSL module or the Crypt::SSLeay module.  The
+README.SSL file will tell you more about how libwww-perl supports SSL.
 
 
 INSTALLATION

Modified: branches/upstream/libwww-perl/current/README.SSL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/README.SSL?rev=72123&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/README.SSL (original)
+++ branches/upstream/libwww-perl/current/README.SSL Thu Mar 31 23:06:07 2011
@@ -1,7 +1,21 @@
-As of libwww-perl v6.02 you need to install the LWP::Protocol::https module
-from its own separate distribution to enable support for https://... URLs for
-LWP::UserAgent.
+SSL SUPPORT
+-----------
 
-This makes it possible for that distribution to state the required dependencies
-as non-optional.  See <https://rt.cpan.org/Ticket/Display.html?id=66838> for
-further discussion why we ended up with this solution.
+The libwww-perl package has support for using SSL/TLSv1 with its HTTP
+client and server classes. This support makes it possible to access
+https schemed URLs with LWP. Because of the problematic status of
+encryption software in general and certain encryption algorithms in
+particular, in several countries, libwww-perl package doesn't include
+SSL functionality out-of-the-box.
+
+Encryption support is obtained through the use of IO::Socket::SSL or
+Crypt::SSLeay, which can both be found from CPAN. While libwww-perl
+has "plug-and-play" support for both of these modules (as of v5.45),
+the recommended module to use is IO::Socket::SSL.
+
+There is yet another SSL interface for perl called Net::SSLeay. It has
+a more complete SSL interface and can be used for web client
+programming among other things but doesn't directly support LWP.
+
+The underlying SSL support in all of these modules is based on OpenSSL
+<http://www.openssl.org/> (formerly SSLeay).

Modified: branches/upstream/libwww-perl/current/lib/LWP.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/lib/LWP.pm?rev=72123&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/LWP.pm (original)
+++ branches/upstream/libwww-perl/current/lib/LWP.pm Thu Mar 31 23:06:07 2011
@@ -1,6 +1,6 @@
 package LWP;
 
-$VERSION = "6.02";
+$VERSION = "6.01";
 sub Version { $VERSION; }
 
 require 5.008;
@@ -595,6 +595,13 @@
 The file and/or directory
 where the trusted Certificate Authority certificates
 is located.  See L<LWP::UserAgent> for details.
+
+=item PERL_LWP_USE_HTTP_10
+
+Enable the old HTTP/1.0 protocol driver instead of the new HTTP/1.1
+driver.  You might want to set this to a TRUE value if you discover
+that your old LWP applications fails after you installed LWP-5.60 or
+better.
 
 =item PERL_HTTP_URI_CLASS
 

Modified: branches/upstream/libwww-perl/current/lib/LWP/ConnCache.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/lib/LWP/ConnCache.pm?rev=72123&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/LWP/ConnCache.pm (original)
+++ branches/upstream/libwww-perl/current/lib/LWP/ConnCache.pm Thu Mar 31 23:06:07 2011
@@ -3,16 +3,13 @@
 use strict;
 use vars qw($VERSION $DEBUG);
 
-$VERSION = "6.02";
+$VERSION = "6.00";
 
 
 sub new {
     my($class, %cnf) = @_;
-
-    my $total_capacity = 1;
-    if (exists $cnf{total_capacity}) {
-        $total_capacity = delete $cnf{total_capacity};
-    }
+    my $total_capacity = delete $cnf{total_capacity};
+    $total_capacity = 1 unless defined $total_capacity;
     if (%cnf && $^W) {
 	require Carp;
 	Carp::carp("Unrecognised options: @{[sort keys %cnf]}")

Added: branches/upstream/libwww-perl/current/lib/LWP/Protocol/http10.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/lib/LWP/Protocol/http10.pm?rev=72123&op=file
==============================================================================
--- branches/upstream/libwww-perl/current/lib/LWP/Protocol/http10.pm (added)
+++ branches/upstream/libwww-perl/current/lib/LWP/Protocol/http10.pm Thu Mar 31 23:06:07 2011
@@ -1,0 +1,290 @@
+package LWP::Protocol::http10;
+
+use strict;
+
+require HTTP::Response;
+require HTTP::Status;
+require IO::Socket;
+require IO::Select;
+
+use vars qw(@ISA @EXTRA_SOCK_OPTS);
+
+require LWP::Protocol;
+ at ISA = qw(LWP::Protocol);
+
+my $CRLF         = "\015\012";     # how lines should be terminated;
+				   # "\r\n" is not correct on all systems, for
+				   # instance MacPerl defines it to "\012\015"
+
+sub _new_socket
+{
+    my($self, $host, $port, $timeout) = @_;
+
+    local($^W) = 0;  # IO::Socket::INET can be noisy
+    my $sock = IO::Socket::INET->new(PeerAddr => $host,
+				     PeerPort  => $port,
+				     LocalAddr => $self->{ua}{local_address},
+				     Proto     => 'tcp',
+				     Timeout   => $timeout,
+				     $self->_extra_sock_opts($host, $port),
+				    );
+    unless ($sock) {
+	# IO::Socket::INET leaves additional error messages in $@
+	$@ =~ s/^.*?: //;
+	die "Can't connect to $host:$port ($@)";
+    }
+    $sock;
+}
+
+sub _extra_sock_opts  # to be overridden by subclass
+{
+    return @EXTRA_SOCK_OPTS;
+}
+
+
+sub _check_sock
+{
+    #my($self, $req, $sock) = @_;
+}
+
+sub _get_sock_info
+{
+    my($self, $res, $sock) = @_;
+    if (defined(my $peerhost = $sock->peerhost)) {
+	$res->header("Client-Peer" => "$peerhost:" . $sock->peerport);
+    }
+}
+
+sub _fixup_header
+{
+    my($self, $h, $url, $proxy) = @_;
+
+    $h->remove_header('Connection');  # need support here to be useful
+
+    # HTTP/1.1 will require us to send the 'Host' header, so we might
+    # as well start now.
+    my $hhost = $url->authority;
+    if ($hhost =~ s/^([^\@]*)\@//) {  # get rid of potential "user:pass@"
+	# add authorization header if we need them.  HTTP URLs do
+	# not really support specification of user and password, but
+	# we allow it.
+	if (defined($1) && not $h->header('Authorization')) {
+	    require URI::Escape;
+	    $h->authorization_basic(map URI::Escape::uri_unescape($_),
+				    split(":", $1, 2));
+	}
+    }
+    $h->init_header('Host' => $hhost);
+
+    if ($proxy) {
+	# Check the proxy URI's userinfo() for proxy credentials
+	# export http_proxy="http://proxyuser:proxypass@proxyhost:port"
+	my $p_auth = $proxy->userinfo();
+	if(defined $p_auth) {
+	    require URI::Escape;
+	    $h->proxy_authorization_basic(map URI::Escape::uri_unescape($_),
+					  split(":", $p_auth, 2))
+	}
+    }
+}
+
+
+sub request
+{
+    my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+
+    $size ||= 4096;
+
+    # check method
+    my $method = $request->method;
+    unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) {  # HTTP token
+	return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
+				  'Library does not allow method ' .
+				  "$method for 'http:' URLs");
+    }
+
+    my $url = $request->uri;
+    my($host, $port, $fullpath);
+
+    # Check if we're proxy'ing
+    if (defined $proxy) {
+	# $proxy is an URL to an HTTP server which will proxy this request
+	$host = $proxy->host;
+	$port = $proxy->port;
+	$fullpath = $method eq "CONNECT" ?
+                       ($url->host . ":" . $url->port) :
+                       $url->as_string;
+    }
+    else {
+	$host = $url->host;
+	$port = $url->port;
+	$fullpath = $url->path_query;
+	$fullpath = "/" unless length $fullpath;
+    }
+
+    # connect to remote site
+    my $socket = $self->_new_socket($host, $port, $timeout);
+    $self->_check_sock($request, $socket);
+
+    my $sel = IO::Select->new($socket) if $timeout;
+
+    my $request_line = "$method $fullpath HTTP/1.0$CRLF";
+
+    my $h = $request->headers->clone;
+    my $cont_ref = $request->content_ref;
+    $cont_ref = $$cont_ref if ref($$cont_ref);
+    my $ctype = ref($cont_ref);
+
+    # If we're sending content we *have* to specify a content length
+    # otherwise the server won't know a messagebody is coming.
+    if ($ctype eq 'CODE') {
+	die 'No Content-Length header for request with dynamic content'
+	    unless defined($h->header('Content-Length')) ||
+		   $h->content_type =~ /^multipart\//;
+	# For HTTP/1.1 we could have used chunked transfer encoding...
+    }
+    else {
+	$h->header('Content-Length' => length $$cont_ref)
+	        if defined($$cont_ref) && length($$cont_ref);
+    }
+
+    $self->_fixup_header($h, $url, $proxy);
+
+    my $buf = $request_line . $h->as_string($CRLF) . $CRLF;
+    my $n;  # used for return value from syswrite/sysread
+    my $length;
+    my $offset;
+
+    # syswrite $buf
+    $length = length($buf);
+    $offset = 0;
+    while ( $offset < $length ) {
+	die "write timeout" if $timeout && !$sel->can_write($timeout);
+	$n = $socket->syswrite($buf, $length-$offset, $offset );
+	die $! unless defined($n);
+	$offset += $n;
+    }
+
+    if ($ctype eq 'CODE') {
+	while ( ($buf = &$cont_ref()), defined($buf) && length($buf)) {
+	    # syswrite $buf
+	    $length = length($buf);
+	    $offset = 0;
+	    while ( $offset < $length ) {
+		die "write timeout" if $timeout && !$sel->can_write($timeout);
+		$n = $socket->syswrite($buf, $length-$offset, $offset );
+		die $! unless defined($n);
+		$offset += $n;
+	    }
+	}
+    }
+    elsif (defined($$cont_ref) && length($$cont_ref)) {
+	# syswrite $$cont_ref
+	$length = length($$cont_ref);
+	$offset = 0;
+	while ( $offset < $length ) {
+	    die "write timeout" if $timeout && !$sel->can_write($timeout);
+	    $n = $socket->syswrite($$cont_ref, $length-$offset, $offset );
+	    die $! unless defined($n);
+	    $offset += $n;
+	}
+    }
+
+    # read response line from server
+    my $response;
+    $buf = '';
+
+    # Inside this loop we will read the response line and all headers
+    # found in the response.
+    while (1) {
+	die "read timeout" if $timeout && !$sel->can_read($timeout);
+	$n = $socket->sysread($buf, $size, length($buf));
+	die $! unless defined($n);
+	die "unexpected EOF before status line seen" unless $n;
+
+	if ($buf =~ s/^(HTTP\/\d+\.\d+)[ \t]+(\d+)[ \t]*([^\012]*)\012//) {
+	    # HTTP/1.0 response or better
+	    my($ver,$code,$msg) = ($1, $2, $3);
+	    $msg =~ s/\015$//;
+	    $response = HTTP::Response->new($code, $msg);
+	    $response->protocol($ver);
+
+	    # ensure that we have read all headers.  The headers will be
+	    # terminated by two blank lines
+	    until ($buf =~ /^\015?\012/ || $buf =~ /\015?\012\015?\012/) {
+		# must read more if we can...
+		die "read timeout" if $timeout && !$sel->can_read($timeout);
+		my $old_len = length($buf);
+		$n = $socket->sysread($buf, $size, $old_len);
+		die $! unless defined($n);
+		die "unexpected EOF before all headers seen" unless $n;
+	    }
+
+	    # now we start parsing the headers.  The strategy is to
+	    # remove one line at a time from the beginning of the header
+	    # buffer ($res).
+	    my($key, $val);
+	    while ($buf =~ s/([^\012]*)\012//) {
+		my $line = $1;
+
+		# if we need to restore as content when illegal headers
+		# are found.
+		my $save = "$line\012"; 
+
+		$line =~ s/\015$//;
+		last unless length $line;
+
+		if ($line =~ /^([a-zA-Z0-9_\-.]+)\s*:\s*(.*)/) {
+		    $response->push_header($key, $val) if $key;
+		    ($key, $val) = ($1, $2);
+		}
+		elsif ($line =~ /^\s+(.*)/ && $key) {
+		    $val .= " $1";
+		}
+		else {
+		    $response->push_header("Client-Bad-Header-Line" => $line);
+		}
+	    }
+	    $response->push_header($key, $val) if $key;
+	    last;
+
+	}
+	elsif ((length($buf) >= 5 and $buf !~ /^HTTP\//) or
+	       $buf =~ /\012/ ) {
+	    # HTTP/0.9 or worse
+	    $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
+	    $response->protocol('HTTP/0.9');
+	    last;
+
+	}
+	else {
+	    # need more data
+	}
+    };
+    $response->request($request);
+    $self->_get_sock_info($response, $socket);
+
+    if ($method eq "CONNECT") {
+	$response->{client_socket} = $socket;  # so it can be picked up
+	$response->content($buf);     # in case we read more than the headers
+	return $response;
+    }
+
+    my $usebuf = length($buf) > 0;
+    $response = $self->collect($arg, $response, sub {
+        if ($usebuf) {
+	    $usebuf = 0;
+	    return \$buf;
+	}
+	die "read timeout" if $timeout && !$sel->can_read($timeout);
+	my $n = $socket->sysread($buf, $size);
+	die $! unless defined($n);
+	return \$buf;
+	} );
+
+    #$socket->close;
+
+    $response;
+}
+
+1;

Added: branches/upstream/libwww-perl/current/lib/LWP/Protocol/https.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/lib/LWP/Protocol/https.pm?rev=72123&op=file
==============================================================================
--- branches/upstream/libwww-perl/current/lib/LWP/Protocol/https.pm (added)
+++ branches/upstream/libwww-perl/current/lib/LWP/Protocol/https.pm Thu Mar 31 23:06:07 2011
@@ -1,0 +1,90 @@
+package LWP::Protocol::https;
+
+use strict;
+
+use vars qw(@ISA);
+require LWP::Protocol::http;
+ at ISA = qw(LWP::Protocol::http);
+
+sub socket_type
+{
+    return "https";
+}
+
+sub _extra_sock_opts
+{
+    my $self = shift;
+    my %ssl_opts = %{$self->{ua}{ssl_opts} || {}};
+    if (delete $ssl_opts{verify_hostname}) {
+	$ssl_opts{SSL_verify_mode} ||= 1;
+	$ssl_opts{SSL_verifycn_scheme} = 'www';
+    }
+    if ($ssl_opts{SSL_verify_mode}) {
+	unless (exists $ssl_opts{SSL_ca_file} || exists $ssl_opts{SSL_ca_path}) {
+	    eval {
+		require Mozilla::CA;
+	    };
+	    if ($@) {
+		if ($@ =! /^Can't locate Mozilla\/CA\.pm/) {
+		    $@ = <<'EOT';
+Can't verify SSL peers without knowning which Certificate Authorities to trust
+
+This problem can be fixed by either setting the PERL_LWP_SSL_CA_FILE
+envirionment variable or by installing the Mozilla::CA module.
+
+To disable verification of SSL peers set the PERL_LWP_SSL_VERIFY_HOSTNAME
+envirionment variable to 0.  If you do this you can't be sure that you
+communicate with the expected peer.
+EOT
+		}
+		die $@;
+	    }
+	    $ssl_opts{SSL_ca_file} = Mozilla::CA::SSL_ca_file();
+	}
+    }
+    $self->{ssl_opts} = \%ssl_opts;
+    return (%ssl_opts, $self->SUPER::_extra_sock_opts);
+}
+
+sub _check_sock
+{
+    my($self, $req, $sock) = @_;
+    my $check = $req->header("If-SSL-Cert-Subject");
+    if (defined $check) {
+	my $cert = $sock->get_peer_certificate ||
+	    die "Missing SSL certificate";
+	my $subject = $cert->subject_name;
+	die "Bad SSL certificate subject: '$subject' !~ /$check/"
+	    unless $subject =~ /$check/;
+	$req->remove_header("If-SSL-Cert-Subject");  # don't pass it on
+    }
+}
+
+sub _get_sock_info
+{
+    my $self = shift;
+    $self->SUPER::_get_sock_info(@_);
+    my($res, $sock) = @_;
+    $res->header("Client-SSL-Cipher" => $sock->get_cipher);
+    my $cert = $sock->get_peer_certificate;
+    if ($cert) {
+	$res->header("Client-SSL-Cert-Subject" => $cert->subject_name);
+	$res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name);
+    }
+    if (!$self->{ssl_opts}{SSL_verify_mode}) {
+	$res->push_header("Client-SSL-Warning" => "Peer certificate not verified");
+    }
+    elsif (!$self->{ssl_opts}{SSL_verifycn_scheme}) {
+	$res->push_header("Client-SSL-Warning" => "Peer hostname match with certificate not verified");
+    }
+    $res->header("Client-SSL-Socket-Class" => $Net::HTTPS::SSL_SOCKET_CLASS);
+}
+
+#-----------------------------------------------------------
+package LWP::Protocol::https::Socket;
+
+use vars qw(@ISA);
+require Net::HTTPS;
+ at ISA = qw(Net::HTTPS LWP::Protocol::http::SocketMethods);
+
+1;

Added: branches/upstream/libwww-perl/current/lib/LWP/Protocol/https10.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/lib/LWP/Protocol/https10.pm?rev=72123&op=file
==============================================================================
--- branches/upstream/libwww-perl/current/lib/LWP/Protocol/https10.pm (added)
+++ branches/upstream/libwww-perl/current/lib/LWP/Protocol/https10.pm Thu Mar 31 23:06:07 2011
@@ -1,0 +1,76 @@
+package LWP::Protocol::https10;
+
+use strict;
+
+# Figure out which SSL implementation to use
+use vars qw($SSL_CLASS);
+if ($Net::SSL::VERSION) {
+    $SSL_CLASS = "Net::SSL";
+}
+elsif ($IO::Socket::SSL::VERSION) {
+    $SSL_CLASS = "IO::Socket::SSL"; # it was already loaded
+}
+else {
+    eval { require Net::SSL; };     # from Crypt-SSLeay
+    if ($@) {
+	require IO::Socket::SSL;
+	$SSL_CLASS = "IO::Socket::SSL";
+    }
+    else {
+	$SSL_CLASS = "Net::SSL";
+    }
+}
+
+
+use vars qw(@ISA);
+
+require LWP::Protocol::http10;
+ at ISA=qw(LWP::Protocol::http10);
+
+sub _new_socket
+{
+    my($self, $host, $port, $timeout) = @_;
+    local($^W) = 0;  # IO::Socket::INET can be noisy
+    my $sock = $SSL_CLASS->new(PeerAddr  => $host,
+			       PeerPort  => $port,
+			       LocalAddr => $self->{ua}{local_address},
+			       Proto     => 'tcp',
+			       Timeout   => $timeout,
+			      );
+    unless ($sock) {
+	# IO::Socket::INET leaves additional error messages in $@
+	$@ =~ s/^.*?: //;
+	die "Can't connect to $host:$port ($@)";
+    }
+    $sock;
+}
+
+sub _check_sock
+{
+    my($self, $req, $sock) = @_;
+    my $check = $req->header("If-SSL-Cert-Subject");
+    if (defined $check) {
+	my $cert = $sock->get_peer_certificate ||
+	    die "Missing SSL certificate";
+	my $subject = $cert->subject_name;
+	die "Bad SSL certificate subject: '$subject' !~ /$check/"
+	    unless $subject =~ /$check/;
+	$req->remove_header("If-SSL-Cert-Subject");  # don't pass it on
+    }
+}
+
+sub _get_sock_info
+{
+    my $self = shift;
+    $self->SUPER::_get_sock_info(@_);
+    my($res, $sock) = @_;
+    $res->header("Client-SSL-Cipher" => $sock->get_cipher);
+    my $cert = $sock->get_peer_certificate;
+    if ($cert) {
+	$res->header("Client-SSL-Cert-Subject" => $cert->subject_name);
+	$res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name);
+    }
+    $res->header("Client-SSL-Warning" => "Peer certificate not verified");
+}
+
+1;

Modified: branches/upstream/libwww-perl/current/lib/LWP/UserAgent.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/lib/LWP/UserAgent.pm?rev=72123&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/lib/LWP/UserAgent.pm (original)
+++ branches/upstream/libwww-perl/current/lib/LWP/UserAgent.pm Thu Mar 31 23:06:07 2011
@@ -5,7 +5,7 @@
 
 require LWP::MemberMixin;
 @ISA = qw(LWP::MemberMixin);
-$VERSION = "6.02";
+$VERSION = "6.00";
 
 use HTTP::Request ();
 use HTTP::Response ();
@@ -15,6 +15,16 @@
 use LWP::Protocol ();
 
 use Carp ();
+
+if ($ENV{PERL_LWP_USE_HTTP_10}) {
+    require LWP::Protocol::http10;
+    LWP::Protocol::implementor('http', 'LWP::Protocol::http10');
+    eval {
+        require LWP::Protocol::https10;
+        LWP::Protocol::implementor('https', 'LWP::Protocol::https10');
+    };
+}
+
 
 
 sub new
@@ -46,13 +56,9 @@
 	else {
 	    $ssl_opts->{verify_hostname} = 1;
 	}
-    }
-    unless (exists $ssl_opts->{SSL_ca_file}) {
 	if (my $ca_file = $ENV{PERL_LWP_SSL_CA_FILE} || $ENV{HTTPS_CA_FILE}) {
 	    $ssl_opts->{SSL_ca_file} = $ca_file;
 	}
-    }
-    unless (exists $ssl_opts->{SSL_ca_path}) {
 	if (my $ca_path = $ENV{PERL_LWP_SSL_CA_PATH} || $ENV{HTTPS_CA_DIR}) {
 	    $ssl_opts->{SSL_ca_path} = $ca_path;
 	}
@@ -177,11 +183,12 @@
                 $@ =~ s/ at .* line \d+.*//s;  # remove file/line number
                 $response =  _new_response($request, &HTTP::Status::RC_NOT_IMPLEMENTED, $@);
                 if ($scheme eq "https") {
-                    $response->message($response->message . " (LWP::Protocol::https not installed)");
+                    $response->message($response->message . " (IO::Socket::SSL not installed)");
                     $response->content_type("text/plain");
                     $response->content(<<EOT);
-LWP will support https URLs if the LWP::Protocol::https module
-is installed.
+LWP will support https URLs if either IO::Socket::SSL or Crypt::SSLeay
+is installed. More information at
+<http://search.cpan.org/dist/libwww-perl/README.SSL>.
 EOT
                 }
             }
@@ -1354,10 +1361,10 @@
 When TRUE LWP will for secure protocol schemes ensure it connects to servers
 that have a valid certificate matching the expected hostname.  If FALSE no
 checks are made and you can't be sure that you communicate with the expected peer.
-The no checks behaviour was the default for libwww-perl-5.837 and earlier releases.
+The no checks behaviour was the default for libwww-perl-5.837 and older.
 
 This option is initialized from the L<PERL_LWP_SSL_VERIFY_HOSTNAME> environment
-variable.  If this envirionment variable isn't set; then C<verify_hostname>
+variable.  If the this envirionment variable isn't set; then C<verify_hostname>
 defaults to 1.
 
 =item C<SSL_ca_file> => $path
@@ -1378,9 +1385,11 @@
 Other options can be set and are processed directly by the SSL Socket implementation
 in use.  See L<IO::Socket::SSL> or L<Net::SSL> for details.
 
-The libwww-perl core no longer bundles protocol plugins for SSL.  You will need
-to install L<LWP::Protocol::https> separately to enable support for processing
-https-URLs.
+If hostname verification is requested, and neither C<SSL_ca_file> nor
+C<SSL_ca_path> is set, then C<SSL_ca_file> is implied to be the one
+provided by L<Mozilla::CA>.  If the Mozilla::CA module isn't available
+SSL requests will fail.  Either install this module, set up an alternative
+SSL_ca_file or disable hostname verification.
 
 =back
 

Modified: branches/upstream/libwww-perl/current/t/TEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/t/TEST?rev=72123&op=diff
==============================================================================
--- branches/upstream/libwww-perl/current/t/TEST (original)
+++ branches/upstream/libwww-perl/current/t/TEST Thu Mar 31 23:06:07 2011
@@ -39,6 +39,7 @@
     @tests = (<base/*.t>, <html/*.t>, <robot/*.t>, <local/*.t>);
     push(@tests,  <live/*.t>) if -f "live/ENABLED";
     push(@tests, <net/*.t>) if -f "net/config.pl";
+    @tests = grep !/jigsaw/, @tests;  # service is not reliable any more
 }
 
 if ($formatter) {

Added: branches/upstream/libwww-perl/current/t/live/https.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwww-perl/current/t/live/https.t?rev=72123&op=file
==============================================================================
--- branches/upstream/libwww-perl/current/t/live/https.t (added)
+++ branches/upstream/libwww-perl/current/t/live/https.t Thu Mar 31 23:06:07 2011
@@ -1,0 +1,20 @@
+#!perl -w
+
+use strict;
+use Test;
+
+use LWP::UserAgent;
+
+my $ua = LWP::UserAgent->new();
+my $res = $ua->simple_request(HTTP::Request->new(GET => "https://www.apache.org"));
+
+if ($res->code == 501 && $res->message =~ /Protocol scheme 'https' is not supported/) {
+    print "1..0 # Skipped: " . $res->message . "\n";
+    exit;
+}
+
+plan tests => 2;
+ok($res->is_success);
+ok($res->content =~ /Apache Software Foundation/);
+
+$res->dump(prefix => "# ");




More information about the Pkg-perl-cvs-commits mailing list