home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2006 December / PCpro_2006_12.ISO / ossdvd / server / Perl2 / site / lib / lwp / Protocol / https.pm < prev    next >
Encoding:
Perl POD Document  |  2001-11-16  |  1.3 KB  |  48 lines
  1. #
  2. package LWP::Protocol::https;
  3.  
  4. # $Id: https.pm,v 1.11 2001/11/17 02:10:28 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.     $res->header("Client-SSL-Warning" => "Peer certificate not verified");
  38. }
  39.  
  40. #-----------------------------------------------------------
  41. package LWP::Protocol::https::Socket;
  42.  
  43. use vars qw(@ISA);
  44. require Net::HTTPS;
  45. @ISA = qw(Net::HTTPS LWP::Protocol::http::SocketMethods);
  46.  
  47. 1;
  48.