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 -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() . ": 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() . ": 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 reaperwhile($zombies) { $zombies = 0; while ((my $zombie = waitpid( -1, WNOHANG)) != -1){}};$client->autoflush(1); #handshakesysread $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 connectionif(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 =~ /()/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 =~ /()/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;}
页:
[1]