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