vcs.maemo.org Git - pkg-perl/blob - deb-src/libwww-perl/libwww-perl-5.813/lib/LWP/Protocol/https.pm

   1 package LWP::Protocol::https;
   2
   3 use strict;
   4
   5 use vars qw(@ISA);
   6 require LWP::Protocol::http;
   7 @ISA = qw(LWP::Protocol::http);
   8
   9 sub _check_sock
  10 {
  11     my($self, $req, $sock) = @_;
  12     my $check = $req->header("If-SSL-Cert-Subject");
  13     if (defined $check) {
  14         my $cert = $sock->get_peer_certificate ||
  15             die "Missing SSL certificate";
  16         my $subject = $cert->subject_name;
  17         die "Bad SSL certificate subject: '$subject' !~ /$check/"
  18             unless $subject =~ /$check/;
  19         $req->remove_header("If-SSL-Cert-Subject");  # don't pass it on
  20     }
  21 }
  22
  23 sub _get_sock_info
  24 {
  25     my $self = shift;
  26     $self->SUPER::_get_sock_info(@_);
  27     my($res, $sock) = @_;
  28     $res->header("Client-SSL-Cipher" => $sock->get_cipher);
  29     my $cert = $sock->get_peer_certificate;
  30     if ($cert) {
  31         $res->header("Client-SSL-Cert-Subject" => $cert->subject_name);
  32         $res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name);
  33     }
  34     if(! eval { $sock->get_peer_verify }) {
  35        $res->header("Client-SSL-Warning" => "Peer certificate not verified");
  36     }
  37 }
  38
  39 #-----------------------------------------------------------
  40 package LWP::Protocol::https::Socket;
  41
  42 use vars qw(@ISA);
  43 require Net::HTTPS;
  44 @ISA = qw(Net::HTTPS LWP::Protocol::http::SocketMethods);
  45
  46 1;