home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _bb9c3de500b9a2780d37e0a2581fb073 < prev    next >
Encoding:
Text File  |  2004-06-01  |  1.9 KB  |  76 lines
  1. #
  2. # $Id: https10.pm,v 1.2 2003/10/23 19:11:33 uid39246 Exp $
  3.  
  4. use strict;
  5.  
  6. package LWP::Protocol::https10;
  7.  
  8. # Figure out which SSL implementation to use
  9. use vars qw($SSL_CLASS);
  10. if ($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;
  76.