git.maemo.org Git - dh-make-perl/blob - dev/arm/libio-socket-ssl-perl/libio-socket-ssl-perl-1.16/debian/libio-socket-ssl-perl/usr/share/doc/libio-socket-ssl-perl/examples/ssl_server.pl

   1 #
   2 # a test server for testing IO::Socket::SSL-class's behavior
   3 # (marko.asplund at kronodoc.fi).
   4 #
   5 # $Id: ssl_server.pl,v 1.7 2000/11/08 09:25:21 aspa Exp $.
   6 #
   7
   8 use strict;
   9 use IO::Socket::SSL;
  10
  11
  12 my ($sock, $s, $v_mode);
  13
  14 if($ARGV[0] eq "DEBUG") { $IO::Socket::SSL::DEBUG = 1; }
  15
  16 # Check to make sure that we were not accidentally run in the wrong
  17 # directory:
  18 unless (-d "certs") {
  19     if (-d "../certs") {
  20         chdir "..";
  21     } else {
  22         die "Please run this example from the IO::Socket::SSL distribution directory!\n";
  23     }
  24 }
  25
  26 if(!($sock = IO::Socket::SSL->new( Listen => 5,
  27                                    LocalAddr => 'localhost',
  28                                    LocalPort => 9000,
  29                                    Proto     => 'tcp',
  30                                    Reuse     => 1,
  31                                    SSL_verify_mode => 0x01,
  32                                    SSL_passwd_cb => sub {return "bluebell"},
  33                                  )) ) {
  34     warn "unable to create socket: ", &IO::Socket::SSL::errstr, "\n";
  35     exit(0);
  36 }
  37 warn "socket created: $sock.\n";
  38
  39 while (1) {
  40   warn "waiting for next connection.\n";
  41
  42   while(($s = $sock->accept())) {
  43       my ($peer_cert, $subject_name, $issuer_name, $date, $str);
  44
  45       if( ! $s ) {
  46           warn "error: ", $sock->errstr, "\n";
  47           next;
  48       }
  49
  50       warn "connection opened ($s).\n";
  51
  52       if( ref($sock) eq "IO::Socket::SSL") {
  53           $subject_name = $s->peer_certificate("subject");
  54           $issuer_name = $s->peer_certificate("issuer");
  55       }
  56
  57       warn "\t subject: '$subject_name'.\n";
  58       warn "\t issuer: '$issuer_name'.\n";
  59
  60       my $date = localtime();
  61       print $s "my date command says it's: '$date'";
  62       close($s);
  63       warn "\t connection closed.\n";
  64   }
  65 }
  66
  67
  68 $sock->close();
  69
  70 warn "loop exited.\n";