git.maemo.org Git - dh-make-perl/blob - dev/arm/libwww-perl/libwww-perl-5.813/debian/libwww-perl/usr/share/perl5/LWP/Protocol/https10.pm

   1 package LWP::Protocol::https10;
   2
   3 use strict;
   4
   5 # Figure out which SSL implementation to use
   6 use vars qw($SSL_CLASS);
   7 if ($Net::SSL::VERSION) {
   8     $SSL_CLASS = "Net::SSL";
   9 }
  10 elsif ($IO::Socket::SSL::VERSION) {
  11     $SSL_CLASS = "IO::Socket::SSL"; # it was already loaded
  12 }
  13 else {
  14     eval { require Net::SSL; };     # from Crypt-SSLeay
  15     if ($@) {
  16         require IO::Socket::SSL;
  17         $SSL_CLASS = "IO::Socket::SSL";
  18     }
  19     else {
  20         $SSL_CLASS = "Net::SSL";
  21     }
  22 }
  23
  24
  25 use vars qw(@ISA);
  26
  27 require LWP::Protocol::http10;
  28 @ISA=qw(LWP::Protocol::http10);
  29
  30 sub _new_socket
  31 {
  32     my($self, $host, $port, $timeout) = @_;
  33     local($^W) = 0;  # IO::Socket::INET can be noisy
  34     my $sock = $SSL_CLASS->new(PeerAddr => $host,
  35                                PeerPort => $port,
  36                                Proto    => 'tcp',
  37                                Timeout  => $timeout,
  38                               );
  39     unless ($sock) {
  40         # IO::Socket::INET leaves additional error messages in $@
  41         $@ =~ s/^.*?: //;
  42         die "Can't connect to $host:$port ($@)";
  43     }
  44     $sock;
  45 }
  46
  47 sub _check_sock
  48 {
  49     my($self, $req, $sock) = @_;
  50     my $check = $req->header("If-SSL-Cert-Subject");
  51     if (defined $check) {
  52         my $cert = $sock->get_peer_certificate ||
  53             die "Missing SSL certificate";
  54         my $subject = $cert->subject_name;
  55         die "Bad SSL certificate subject: '$subject' !~ /$check/"
  56             unless $subject =~ /$check/;
  57         $req->remove_header("If-SSL-Cert-Subject");  # don't pass it on
  58     }
  59 }
  60
  61 sub _get_sock_info
  62 {
  63     my $self = shift;
  64     $self->SUPER::_get_sock_info(@_);
  65     my($res, $sock) = @_;
  66     $res->header("Client-SSL-Cipher" => $sock->get_cipher);
  67     my $cert = $sock->get_peer_certificate;
  68     if ($cert) {
  69         $res->header("Client-SSL-Cert-Subject" => $cert->subject_name);
  70         $res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name);
  71     }
  72     $res->header("Client-SSL-Warning" => "Peer certificate not verified");
  73 }
  74
  75 1;