Perl实现Websocket-76的TCP并发连接服务器端

直接上代码：

 

################################################################################
# Filename:
#   websocket.pl
# Description:
#   Perl mutithreaded TCP server of HTML5 Websocket-draft-76
# Test enviroment:
#   OS      - Windows XP
#   Perl    - ActivePerl 5.12.1
#   Browser - Chrome 8.0
################################################################################
#!/usr/bin/perl -w
use strict;
use warnings;
use 5.010;

use IO::Socket::INET;
use Digest::MD5 qw/md5/;
use Redis;
use POSIX ':sys_wait_h';

### main part ##################################################################
### system level options
my %VARS = (
  DEBUG => 1,
  LOG2FILE => 0
);

#common global variables
my @TIMER_TASK;   #its element is %{task_name, interval fun_ref}

### stdout to log file
if( $VARS{LOG2FILE} ){
  open LOG, ">>syslog.txt";
  select LOG;
}

### redis db initialization
my $r = Redis->new;
$r->ping or die now() . "[Server]: connect Redis failed";
$r->flushall;

my $redis_sock = $$r{sock};
$r->hset("sys:sock", "redis", $redis_sock);
say now() . " | Redis: " . $redis_sock->sockhost() . ":" . $redis_sock->sockport() .
    " <---> " . $redis_sock->peerhost() . ":" . $redis_sock->peerport();

### tcp server
my $PORT = 8000;
my $server = IO::Socket::INET->new( Proto     => 'tcp',
                                 LocalPort => $PORT,
                                 Listen    => 255,
                                 Reuse     => 1);
$server or die now() . "[Server]: Err = can't setup server";
say now() . " | Server: Listening at TCP:" . $server->sockport;

#zombie
my $zombies = 0;
$SIG{CHLD} = sub {$zombies++;};

while(my $client = $server->accept()){
  #zombie reaper
  while($zombies) {
    $zombies = 0;
    while ((my $zombie = waitpid( -1, WNOHANG)) != -1){}
  };
  $client->autoflush(1);
 
  #handshake
  sysread $client, my $handshake_req, 1024;
  my($handshake_resp,$page) = handshake($handshake_req);
  print $client $handshake_resp;
  
  close $client unless $client;
  my $client_info = $client->peerhost() . ":" . $client->peerport() . "$page";
  $r->hset("sys:sock", $client_info,$client);
  say now() . " | Client: connected from " . $client_info;
  
  #data framing
  $client->blocking(0);

  #fork child for new connection
  if(my $child = fork()){     
    $/ = "\xff";  #new line seperator
    my($req,@resp);
    while(<$client>){    
      /\x00(.*)\xff/;
      $req = $1;   
      say now() . " | ws://" . "$client_info >>> [$req]" if $VARS{DEBUG};

   
      @resp = request($req);
      foreach my $resp (@resp){
        say now() . " | ws://" . "$client_info <<< [$resp]" if $VARS{DEBUG};
        print $client "\x00$resp\xff";
      }    
    }

    return;    #go back to parent
  }
}

### sub routines ###############################################################
# Description:  Request format from webSocket
# Format:       command param1,param2, ... ,paramN
sub request{
  my @resp = ();
  $_ = shift;  
  my($cmd, @param) = split / /;
  $cmd = "req_$cmd";
  
  if(defined(&$cmd)){
    no strict 'refs';
    @resp = $cmd->(@param);
  }else{
    push @resp, "!$_";
  }
  return @resp;
}

sub req_echo{ return @_; }
sub req_random{
  $_ = shift;
  my $r;
  if(/float/){ #float
    $r = rand(100);
  }else{    #integer
    $_ = "int";
    $r = int(rand(100));
  }
  return ("random: $_ = $r");
}

sub req_showsock{
  my @socks = ();
  my %s = $r->hgetall("sys:sock");
  say "..............";
  foreach (keys %s){
    say ;
    #push @socks, $item;
  }
  return @socks;
}



sub now{
  my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime(time);
  $year += 1900;
  return sprintf("%.4d-%.2d-%.2d %2d:%.2d:%.2d",$year,$mon,$mday,$hour,$min,$sec);
}

sub handshake{
  my $req = shift;
  ($req, my $key3) = split /\r\n\r\n/, $req;  
  my @req = split /\r\n/, $req;
  
  my $field = shift @req;
  $field =~ /GET (.*) HTTP/;
  my $page = $1;
  
  $field = shift @req;
  $field = shift @req;
  $field = shift @req;
  $field =~ /Host: (.*)/;
  my $location = "ws://" . $1 . $page;
  
  $field = shift @req;
  $field =~ /Origin: (.*)/;
  my $origin = $1;
  
  $field = shift @req;
  $field =~ /Sec-WebSocket-Key1: (.*)/;
  $field = $1;
  my @key1= $field =~ /([0-9])/g;
  my $key1 = join('', @key1) + 0;
  my @space1 = $field =~ /\x20/g;
  my $space1 = @space1 + 0;
  my $part1 = $key1 / $space1;
  my $part1_hex = pack 'L>', $part1;
  
  $field = shift @req;
  $field =~ /Sec-WebSocket-Key2: (.*)/;
  $field = $1;
  my @key2 = $field =~ /([0-9])/g;
  my $key2 = join('', @key2) + 0;
  my @space2 = $field =~ /\x20/g;
  my $space2 = @space2 + 0;
  my $part2 = $key2 / $space2;
  my $part2_hex = pack 'L>', $part2;
  
  my $challenge = md5($part1_hex, $part2_hex, $key3);
  my $resp = "HTTP/1.1 101 Web Socket Protocol Handshake\r\n" .
            "Upgrade: WebSocket\r\n" . 
            "Connection: Upgrade\r\n" .
            "Sec-WebSocket-Origin: $origin\r\n" .
            "Sec-WebSocket-Location: $location\r\n\r\n" . $challenge;  
  return ($resp, $page);
}

sub hexcode{
  my $str = unpack 'H*', shift;
  $str =~ s/(.)(.)/\U$1$2 /g;
  return $str;
}