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

xumingyong

直接上代码：
 

################################################################################# 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 -wuse 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 optionsmy %VARS = (  DEBUG => 1,  LOG2FILE => 0);#common global variablesmy @TIMER_TASK;   #its element is %{task_name, interval fun_ref}### stdout to log fileif( $VARS{LOG2FILE} ){  open LOG, ">>syslog.txt";  select LOG;}### redis db initializationmy $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 servermy $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;#zombiemy $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, ... ,paramNsub 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;}