home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _9058c9d758f75eba07aeb996b224a531 < prev    next >
Encoding:
Text File  |  2004-06-01  |  1.3 KB  |  50 lines
  1. #
  2. package LWP::Protocol::https;
  3.  
  4. # $Id: https.pm,v 1.12 2003/10/15 10:35:47 gisle Exp $
  5.  
  6. use strict;
  7.  
  8. use vars qw(@ISA);
  9. require LWP::Protocol::http;
  10. @ISA = qw(LWP::Protocol::http);
  11.  
  12. sub _check_sock
  13. {
  14.     my($self, $req, $sock) = @_;
  15.     my $check = $req->header("If-SSL-Cert-Subject");
  16.     if (defined $check) {
  17.     my $cert = $sock->get_peer_certificate ||
  18.         die "Missing SSL certificate";
  19.     my $subject = $cert->subject_name;
  20.     die "Bad SSL certificate subject: '$subject' !~ /$check/"
  21.         unless $subject =~ /$check/;
  22.     $req->remove_header("If-SSL-Cert-Subject");  # don't pass it on
  23.     }
  24. }
  25.  
  26. sub _get_sock_info
  27. {
  28.     my $self = shift;
  29.     $self->SUPER::_get_sock_info(@_);
  30.     my($res, $sock) = @_;
  31.     $res->header("Client-SSL-Cipher" => $sock->get_cipher);
  32.     my $cert = $sock->get_peer_certificate;
  33.     if ($cert) {
  34.     $res->header("Client-SSL-Cert-Subject" => $cert->subject_name);
  35.     $res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name);
  36.     }
  37.     if(! eval { $sock->get_peer_verify }) {
  38.        $res->header("Client-SSL-Warning" => "Peer certificate not verified");
  39.     }
  40. }
  41.  
  42. #-----------------------------------------------------------
  43. package LWP::Protocol::https::Socket;
  44.  
  45. use vars qw(@ISA);
  46. require Net::HTTPS;
  47. @ISA = qw(Net::HTTPS LWP::Protocol::http::SocketMethods);
  48.  
  49. 1;
  50.