home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _fe4179946b342a7d3be29e98a2d7a9ea < prev    next >
Encoding:
Text File  |  2000-03-15  |  1.8 KB  |  74 lines
  1. #
  2. # $Id: https.pm,v 1.8 1999/09/20 12:48:37 gisle Exp $
  3.  
  4. use strict;
  5.  
  6. package LWP::Protocol::https;
  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. } else {
  13.     eval { require Net::SSL; };     # from Crypt-SSLeay
  14.     if ($@) {
  15.     require IO::Socket::SSL;
  16.     $SSL_CLASS = "IO::Socket::SSL";
  17.     } else {
  18.     $SSL_CLASS = "Net::SSL";
  19.     }
  20. }
  21.  
  22.  
  23. use vars qw(@ISA);
  24.  
  25. require LWP::Protocol::http;
  26. @ISA=qw(LWP::Protocol::http);
  27.  
  28. sub _new_socket
  29. {
  30.     my($self, $host, $port, $timeout) = @_;
  31.     local($^W) = 0;  # IO::Socket::INET can be noisy
  32.     my $sock = $SSL_CLASS->new(PeerAddr => $host,
  33.                    PeerPort => $port,
  34.                    Proto    => 'tcp',
  35.                    Timeout  => $timeout,
  36.                   );
  37.     unless ($sock) {
  38.     # IO::Socket::INET leaves additional error messages in $@
  39.     $@ =~ s/^.*?: //;
  40.     die "Can't connect to $host:$port ($@)";
  41.     }
  42.     $sock;
  43. }
  44.  
  45. sub _check_sock
  46. {
  47.     my($self, $req, $sock) = @_;
  48.     my $check = $req->header("If-SSL-Cert-Subject");
  49.     if (defined $check) {
  50.     my $cert = $sock->get_peer_certificate ||
  51.         die "Missing SSL certificate";
  52.     my $subject = $cert->subject_name;
  53.     die "Bad SSL certificate subject: '$subject' !~ /$check/"
  54.         unless $subject =~ /$check/;
  55.     $req->remove_header("If-SSL-Cert-Subject");  # don't pass it on
  56.     }
  57. }
  58.  
  59. sub _get_sock_info
  60. {
  61.     my $self = shift;
  62.     $self->SUPER::_get_sock_info(@_);
  63.     my($res, $sock) = @_;
  64.     $res->header("Client-SSL-Cipher" => $sock->get_cipher);
  65.     my $cert = $sock->get_peer_certificate;
  66.     if ($cert) {
  67.     $res->header("Client-SSL-Cert-Subject" => $cert->subject_name);
  68.     $res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name);
  69.     }
  70.     $res->header("Client-SSL-Warning" => "Peer certificate not verified");
  71. }
  72.  
  73. 1;
  74.