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

shenhp

　　直接上代码：
　　


################################################################################
# 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;
}