当程序中包含可能的错误时,可以要求 Perl 警告你。

运行程序时,可以在命令行中使用 –w 这个参数把警告打开:

$ perl –w my_program

或者,如果一直都需要警告(warning),可以在 # ! 这一行加上-w,如:

#! /usr/bin/perl –w

这条命令甚至在 non-Unix 系统中也有效。

今天想尝试Perl链接Mysql数据库的操作，可DBD::mysql安装了N次就是不行，遇到的错误：

Cannot find the file 'mysql_config'! Your execution PATH doesn't seem
not contain the path to mysql_config. Resorting to guessed values!
Can't exec "mysql_config": No such file or directory at Makefile.PL 
line 466.

可我添加了--mysql_config的路径，仍然不能成功，最后还是找到把mysql_config的路径直接添加到$PATH中，才安装OK!

<perl Makefile.Pl --testuser=root --testdb=test --testhost=localhost>

make

sudo make install

安装成功，下面进行测试：

#!/usr/bin/perl -w

use DBI;
use strict;
use warnings;

my $dsn = 'DBI:mysql:test:localhost';
my $db_user_name = 'root';
my $db_password = '';

my $dbh = DBI->connect($dsn, $db_user_name, $db_password);

print "$dbh" if "$dbh";

输出<DBI::db=HASH(0x504888)>

应该是DBI对象了，ok继续前进！

LY from http://fanqiang.chinaunix.net/program/perl/2005-06-28/3349.shtml

是否觉得perl中关于模块的文档有些难懂？好的，这里有一个世界上最简单的模块，它将用于展示(demonstrate)Exporter模块所 有的特性，另外还有一段使用这个模块的脚本。同时，我们也会给出一个有关于@INC的简短说明，最后，还要讲一下有些关于using warnings和use模块的使用。

下面是这个模块的内容：

MyModule.pm

package MyModule;

use strict;
use Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

$VERSION     = 1.00;
@ISA         = qw(Exporter);
@EXPORT      = ();
@EXPORT_OK   = qw(func1 func2);
%EXPORT_TAGS = ( DEFAULT => [qw(&func1)],
                 Both    => [qw(&func1 &func2)]);

sub func1  { return reverse @_  }
sub func2  { return map{ uc }@_ }

1;

首先，我们将通过声明 "package" 名字来获得一个名字空间。这将确保模块中的方法与变量，和调用他们的代码所分隔开来。 use strict在模块中是一个非常好的做法，这将使Perl对使用全局变量做出一定的约束。详细介绍参看 "use strict warnings and diagnostics or die" 。

我们需要用Exporter模块来将我们的函数从MyModule::namespace输出到main::namespace，让使用 MyModule的程序可以使用这些函数。 为了use strict，我们必须使用use vars来声明一些变量。当然，在5.6版本以上我们还可以使用our来声明变量。 我们现在设置一个$VERSION数值，然后通过使用@ISA来使得Exporter成为MyModule的一部本。想要了解@ISA是什么以及如何使用 等细节，请参考"perlboot"。

@EXPORT包含了我们需要默认输出的函数列表。在这里，它是空的。一般来说，你通过默认的使用@EXPROT输出的越少越好。因为调用该模块的 程序中，有可能存在与其中函数相之冲突的函数或者代码。如果程序需要调用某个指定的函数，那么，就请就让它主动请求。 @EXPORT_OK包含了我们在调用时需要输出的函数列表，我们只输出了&func1和&func2，这种方法要优先于盲目地使用 @EXPORT来输出函数。你也可以输出像$CONFIG这样全局的、不是用my定义的字义范畴的变量。（可参考用 "our" 或者 use vars来声明全局变量） %EXPORT_TAGS.为了方便起见，我们定义了两套输出标签。‘:DEFAULT’标签只输出&func1；‘:Both’标签则输出 &func1和&func2。这个哈希表存储指向数组引用的标签。注意：在这里的数组是匿名的。 最后，我们需要在模块结尾加上一个“1;”。因为当perl装载一个模块时，它会实现查看这个模块是否能在最后返回一个真值，并且据此判断该模块是否已装 载成功。当然，你可以在最后面添加任何真值（参看 "Code::Police" ），但其中1是最方便的。

MySciprt.pl（使用MyModule的一个例子）

#!/usr/bin/perl -w

use strict;

# you may need to set @INC here (see below)

my @list = qw (J u s t ~ A n o t h e r ~ P e r l ~ H a c k e r !);

# case 1
# use MyModule;
# print func1(@list),"\n";
# print func2(@list),"\n";

# case 2
# use MyModule qw(&func1);
# print func1(@list),"\n";
# print MyModule::func2(@list),"\n";

# case 3
# use MyModule qw(:DEFAULT);
# print func1(@list),"\n";
# print func2(@list),"\n";

# case 4
# use MyModule qw(:Both);
# print func1(@list),"\n";
# print func2(@list),"\n";

正如上面所见，我们在MyScript.pl中使用了MyModule。把中间的注释符号都去掉来看看会发生什么。一次都去掉即可。 Case1:因为我们的模块默认什么都没有输出（没有输出&func1和&func2），所以我们会得到一个他们在main:: namespace中不存在的错误。 Case2:这个运行正常。我们让模块输出了&func1,于是我们可以正常使用它。尽管我们没有输出&func2，但是我们使用的是 &func2完整的包路径，所以它也可以正常工作。 Case3:‘:DEFAULT’标签应该输出&func1，所以你应该希望返回一个缺少&func2函数的错误。但事实上perl却偏 偏找上了&func1的麻烦（错误信息提示未定义&func1函数）。恩,这里怎么了呢？原来，DEFAULT这个标签名字是特殊的，在 我们的模块中，%EXPORT_TAGS哈希表它会被自动设置成这样DEFAULT=>\@EXPROT.也就是说，DEFAULT默认导出的是来 自@EXPROT数组的函数。 Case4:我们指定通过‘:Both’标签实现两个函数都输出，他实现了。 *关于@INC的注意事项* 当你提交一个use MyModule的时候，就会指示perl去搜索@INC数组中是否有此模块名。@INC通常包含：

/perl/lib 
/perl/site/lib
.

“.”这个目录表示当前的工作目录。核心模块是安装在perl/lib目录中，非核心模块安装在perl/site/lib目录中。你可以向@INC中添加自定义目录。像下面这样：

BEGIN { push @INC, '/my/dir' }
# or
BEGIN { unshift @INC, '/my/dir' }
# or
use lib '/my/dir';

我们需要使用BEGIN块在编译时向@INC中添加值，此时是perl检查模块的时刻。

如果你等到程序被编译的时候就太晚了，perl会抛出一个异常，说“在@INC中无法找到MyModule”.使用push还是unshift方法 添加值的区别是，perl搜索@INC的顺序是从@INC中的第一个目录开始的。如果你在/perl/lib/、/perl/site/lib/和./中 都有一个MyModule模块的话，那么/perl/lib中的模块将首先被找到并使用。use lib用法可以起到和BEGIN{unshift @INC,$dir}一样的效果－请参看"perlman:lib:lib":http://www.perlmonks.org/?node= perlman%3Alib%3Alib . *use Foo::Bar意味着什么* use Foo::Bar并不意味着在@INC的目录中寻找一个叫做Foo::Bar.pm的模块文件。它的意思是在@INC的目录中寻找一个叫做‘Foo’的 “子目录”，然后在其中找一个叫做“Bar.pm”的“模块”。 现在，如果我们成功"use"了一个模块，那么我们就可以通过完整的包路径语法&PACKAGE::FUNCTION使用这个模块中的所有函数。 当我们说&Foo::Bar::some_func的时候，我们指的是“包的名字”而不是那个在use中曾使用的包含路径的文件名。这会允许你可 以在一个use过的文件中包含很多包名字。实际使用中这些名字通常是相同的。

use warnings;

你应该打开warnings来检测你的模块，因为它可以检测出很多细微的错误。你可以通过在测试模块代码中添加-w参数来打开警告选项。如果你在模 块中添加了use warnings，那么你的模块必须要求运行在perl5.6以上，否则不支持。如果你在模块的顶端添加了$^W++，那么你将会在全局范围内打开警告选 项－这将影响到其他模块，你最好只在你自己的程序中这么使用，因为这略显霸道了一些。这有一个专家写的叫做"tye":http: //www.perlmonks.org/?node=tye 的代码来测试警告选项，但没有直接将它包含进他/她自己的模块中。 希望这些会讲清楚它是怎样工作的。

基于perl,使用IO::Select实现，并非多线程。可指定分几部分下载。
基本上没有作异常处理，没有处理redirect,甚至也没有判断对range头的响应是否为206.

还好的是它还可以工作，比wget快几倍地下载,挺好玩的.

perl module:

package HttpClient;

use strict;
use warnings;

use IO::Socket::INET;
use Data::Dumper;

my $crlf = “\r\n”;

my $buf_size = 8 * 1024;

sub new {
my $class = shift;
my %cnf = (@_);
my $self = {
state => ‘init’,
url => $cnf{url},
‘total_parts’ => $cnf{’total_parts’},
part => $cnf{part},
‘content_length’ => $cnf{’content_length’},
};
my $url = $self->{url};
my $host = $1 if $url =~ m{://([^/]*)};
my $file = $1 if $url =~ m{/([^/]*)$};
if ( defined $self->{part} ) {
$file .= “.part” . $self->{part};
}
$self->{host} = $host;
$self->{file} = $file;
my $port = 80;
$port = $1 if $host =~ /:(\d+)/;
my $sock = IO::Socket::INET->new(
PeerAddr => $host,
PeerPort => $port,
Proto => ‘tcp’,
Blocking => 0,
)
or die “can’t connect to server:$!\n”;
select($sock);
$| = 1;
select(STDOUT);
$self->{sock} = $sock;
bless $self, $class;
return $self;
}

sub sock {
return shift->{sock};
}

sub get_request_header {
my $self = shift;
return $self->{request} if defined $self->{request};
my $request =
“GET $self->{url} HTTP/1.1$crlf”
. “Host: $self->{host}$crlf”
. “Connection: close$crlf”;
if ( defined $self->{’total_parts’}
and defined $self->{part}
and defined $self->{’content_length’} )
{
my $length = $self->{’content_length’};
my $total_parts = $self->{’total_parts’};
my $part = $self->{part};
my $part_size = int( $length / $total_parts );
my $start_pos = $part_size * $part;
my $recved = 0;
if (-e $self->{file}) {
$recved = -s $self->{file};
$start_pos+=$recved;
}

my $recv_size =
( $part == $total_parts - 1 ) ? $length-$part*$part_size : $part_size;
$self->{start_pos} = $start_pos;
$self->{recv_size} = $recv_size-$recved;
print “part $self->{part} recv_size=$self->{recv_size},start_pos=$start_pos,recved=$recved,parts=$total_parts,length=$length\n”;
$request .=
“Range: bytes=$start_pos-” . ( $start_pos + $recv_size-1 ) . $crlf;
}
$request .= $crlf;
$self->{request} = $request;
return $request;
}

sub parse_header {
my ($self) = @_;
my $data = $self->{data};
return 1 if $self->{state} =~ /body/;
return 0 unless defined $data;
return 0 unless $data =~ m{^(.*?)(\r\n\r\n|\n\n)}s;
my $header_content = $1;
my $header_end = $2;
print $header_content, “\n”;
my @headers = split /\r?\n/, $header_content;
die “invalid header\n” unless scalar(@headers) > 0;
my $status_line = shift @headers;
$self->{status_line} = $status_line;
$self->{code} = $2 if $status_line =~ m{HTTP/1(.1)? (\d+)};
my $last_header;
my $header = {};

foreach my $line (@headers) {
if ( $line =~ /^\s+(.*)$/ ) {
$header->{$last_header} .= ” $1″;
}
elsif ( $line =~ /^([^:]+): (.*)$/ ) {
$last_header = $1;
my $value = $2;
$header->{$last_header} = $value;
}
else {
print “invalid header:$line\n”;
}
}
$self->{header} = $header;
$self->{’content_length’} = $header->{’Content-Length’}
unless defined $self->{’content_length’};
$self->{recv_size} = $self->{’content_length’};
$self->{data} = substr($data,length($header_content)+length($header_end));
$self->{state} = ‘body’;
return 1;
}

sub recv_data {
my ( $self, $data ) = @_;
if ( defined $self->{data} ) {
$self->{data} .= $data;
}
else {
$self->{data} = $data;
}
}

sub save_data {
my ( $self, $read_select ) = @_;
my $fh = $self->{fh};
if ( !defined $fh ) {
open $fh, “>$self->{file}” or die “can’t open file $self->{file} :$!\n”;
binmode $fh,”:bytes”;
$self->{fh} = $fh;
}
my $write_len = $self->{write_len} || 0;
my $recv_size = $self->{recv_size};
my $data = $self->{data};
my $max_len = length($data);
return unless $max_len > 0;
if ($max_len+$write_len > $recv_size) {
$max_len = $recv_size - $write_len ;
my $part = $self->{part} || 0;
print “part=$part,max_len=$max_len,write_len=$write_len\n”;
}

if ( $max_len == 0 ) {
$self->{done} = 1;
close $self->{fh};
$read_select->remove( $self->sock );
close $self->{sock};
print “$self->{file} recved $write_len bytes\n”;
$self->{parent}->child_done($self) if $self->{parent};
return;
}
my $len = syswrite( $fh, $data, $max_len )
or die “write data failed :$!\n”;
$self->{data} = substr( $data, $len );
$write_len += $len;
$self->{write_len} = $write_len;
}

sub child_done {
my ( $self, $child ) = @_;
$child->{done} = 1;
return unless $self->{done};
foreach my $c ( @{ $self->{children} } ) {
return unless $c->{done};
}

print “merge file\n”;
open FH, “>>$self->{file}”;
print “first part size:”,-s $self->{file},”\n”;
seek( FH, 0, 2 );
foreach my $c ( @{ $self->{children} } ) {
print “$c->{file} size:”,-s $c->{file},”\n”;
open CFH, “<$c->{file}”;

print “merge $c->{file}\n”;
my $buf;
for ( ; ; ) {
my $len = sysread( CFH, $buf, $buf_size );
last if !defined $len || $len == 0;
syswrite( FH, $buf, $len );
}
close CFH;
unlink $c->{file};
}
close FH;
}

sub handle_read {
my ( $self, $sock, $read_select, $write_select, $sock_client ) = @_;

my $data;
my $len = sysread( $sock, $data, $buf_size );
if ( $len == 0 ) {
print “sock $sock finished\n”;
$read_select->remove($sock);
close $sock;
print “$self->{file} size=”,-s $self->{file},”\n”;
$self->{parent}->child_done($self) if $self->{parent};
return;
}
$self->recv_data($data);
if ( $self->{state} !~ /body/ and $self->parse_header ) {
if ( !defined $self->{parent} and defined $self->{content_length} ) {
my $parts = $self->{total_parts} || 5;
$self->{children} = [];
my $length = $self->{’content_length’};
my $part_size = int( $length / $parts );
$self->{recv_size} = $part_size;
print “parent recv_size=$self->{recv_size}\n”;
foreach my $part ( 1 .. $parts - 1 ) {
my $child = HttpClient->new(
url => $self->{url},
‘total_parts’ => $parts,
part => $part,
‘content_length’ => $self->{content_length},
);
$sock_client->{ $child->sock } = $child;
$child->{parent} = $self;
push @{ $self->{children} }, $child;
$read_select->add( $child->sock );
$write_select->add( $child->sock );
}
}
}
else {
$self->save_data($read_select);
}
}

sub handle_write {
my ( $self, $sock, $read_select, $write_select, $sock_client ) = @_;

my $offset = 0;
$offset = $self->{request_offset} if defined $self->{request_offset};
my $request = $self->get_request_header;
if ( $offset == 0 ) {
print “try to send request\n”;
print $request;
}
print “offset=$offset\n”;
my $len = syswrite( $sock, $request, length($request) - $offset, $offset );
if ( !defined $len ) {
print STDERR “write failed:$!\n”;
$read_select->remove($sock);
$write_select->remove($sock);
}
else {
$offset += $len;
$self->{request_offset} = $offset;
if ( $offset == length($request) ) {
$write_select->remove($sock);
}
}
}

sub start {
my ($self) = @_;
use IO::Select;
my $r = IO::Select->new;
$r->add( $self->sock );

my $w = IO::Select->new;
$w->add( $self->sock );

my $sock_client = { $self->sock => $self };

use Time::HiRes qw(time);
my $start_time = time;
for ( ; ; ) {
last if ( $r->count == 0 );
my ( $rout, $wout, $eout ) = IO::Select->select( $r, $w, $r );
last unless defined $rout;

foreach my $sock ( @{$wout} ) {
my $c = $sock_client->{$sock};
if ( !defined $c ) {
die “oops,can’t find httpclient for $sock\n”;
}
$c->handle_write( $sock, $r, $w, $sock_client );
}
foreach my $sock ( @{$rout} ) {
my $c = $sock_client->{$sock};
if ( !defined $c ) {
die “oops,can’t find httpclient for $sock\n”;
}
$c->handle_read( $sock, $r, $w, $sock_client );
}
}
my $end_time = time;
my $used_time = $end_time - $start_time;
my $speed = $self->{content_length} / $used_time;
print “Done,spend $used_time seconds,speed:$speed bytes/seconds\n”;
}

1;

test perl script:

#!/usr/bin/perl
use strict;
use warnings;

use lib ‘.’;

use HttpClient;
use Getopt::Long;
$| = 1;
#my $url = ‘http://eclipse.cdpa.nsysu.edu.tw/downloads/drops/R-3.2.1-200609210945/eclipse-SDK-3.2.1-linux-gtk.tar.gz’;

my $url = ”;
my $total_parts = 1;
my $result = GetOptions (”url|u=s” => \$url,
                        “parts|p=i”   => \$total_parts,
                        );
unless ($result and $url=~m{://}) {
    print <<HELP
usage: perl http.pl –url=url [–parts=parts]
HELP
;
    exit;
}

my $client = HttpClient->new(url=>$url,’total_parts’=>$total_parts);
$client->start();

zz <http://blog.csdn.net/evane1890/archive/2007/06/02/1635452.aspx>

 

原作者:Brian Slesinsky 1997年5月7日
编译者:【Perl之旅】Nighthawk 2000年7月15日
Brian Slesinsky原来是HotWired公司的工程师，后来他离开公司忙于自己事业。

前言:

我对在线聊天没有什么兴趣,说是实在的,与电子邮件和网络会议系统相比,聊天室显得很肤浅.但是写一个聊天室服务程序倒是一件很有意思的事情.我将告诉你如何来写一个小型的聊天室服务程序,可能会很简陋,有很多要扩展的地方.

先决条件:

你 必须有很好的Perl编程的知识,一台服务器,安装Perl 5.002或更高的版本.注意大多数ISP不会允许普通用户运行聊天室程序.但是你也许可以通过一个MODEN连接来与少数几个用户试试你的聊天室系统. (如果你从CPAN获得了最新版本的IO:Select,这个聊天室程序可以在Windows环境下使用).

你还需要一个telnet客户端程序,因为我们要用来做聊天室的客户端.



Socket简易编程:

开 始聊天,你需要在internet上建立一个连接,对Perl程序员来说,这意味着要和socket打交道.而以前这是很困难的,因为你不得不使用 pack()来建立一个C结构来进行底层的系统调用.但在最新版的Perl中我们可以使用IO::Socket包,很容易地打开一个socket. 当用户连接聊天服务器时,telnet程序在指定的端口打开一个连接,所以服务器也必须在那个端口打开一个socket,监听所有进来的连接.下面如何通 过IO::Socket来做到这一点:

    use IO::Socket;

    my $listening_socket =
        IO::Socket::INET->new(Proto => 'tcp',
                              LocalPort => 2323,
                              Listen => 1,
                              Reuse => 1) or die $!;

所有参量的含义:

Proto: 定义网络所用的协议 - 在这里我们用的是TCP. 在internet上通常有两种协议用得比较广泛 - TCP 和 UDP. TCP适用于稳定的连接,可以重新发送丢失的数据包,而UDP用于那些不用重发数据包的场合(如实时音频数据流).

LocalPort: 定义连接的端口号.

Listen: 我们将监听来自其它计算机的连接,而不是自己建立一个连接.所以用户要先telnet到端口2323,然后运行了聊天服务程序的计算机来建立连接.

Reuse: 这个选项意思是如果我们"杀掉"聊天服务程序然后再重新启动,将能够马上重新使用原来的端口,而不用等待以前那个连接完全结束.



我们正等待某个连接的到来.... 一个连接到来以后,我们需要accept这个新的连接:

$socket = $listening_socket->accept;

一旦我们建立了一个连接,我们可以发送一些文字给这个用户(还不完全是,请看本文的结尾部分):

$socket->send("hello\r\n") or print "connection closed at other end\n";

我们也可以接收用户发来的信息:

$socket->recv($line, 80);
if($line eq "") {
print "connection closed at other end\n";
}

最后我们完成了连接,可以关闭它:

$socket->close;

大部分程序只在一个时刻处理一个用户.如果用户还没有准备好,程序就没有什么好做的.所以Perl程序没有从读到什么东西,它就停下来等待直到用户准备好. (这叫blocking I/O.)

这种方式不能用于聊天服务程序,用户不可能排着队来.一个用户可能离开去喝些咖啡,但其它用户还在拼命地敲打键盘(聊天),服务程序还得处理他们的信息.

解 决这个问题的一个办法是为每个用户创建一个入口(entity),或者用fork()创建另外一个进程,或者用多线程编程方法(遗憾地是Perl还用不 了).这样系统就可以为多个用户服务, 但每个用户有他自己的入口(entity)等待他输入命令. 但是进程的系统开销比较大,如果很多用户登录的话,系统资源很快会变得不足.最好是用一个进程来处理所有人的请求.

我们真正需要的是要知道谁正在等待服务,必须马上处理(除非没有一个人想聊天).这就是select()函数所要做的.

象socket函数一样,select()曾经也是很难用,所以大多数程序员都尽量避免使用它. 但Perl给它加了一个面向对象编程的包装,叫做IO::Select,使得使用非常简单.

假设我们要等待两个sockets, $thing1 and $thing2. 首先我们创建一个包含两个socket的select()对象:

$select = IO::Select->new($thing1,$thing2);

下一步,当我们需要知道谁有数据要处理时,我们就查询select对象:

my @ready = $select->can_read;

这个调用将等待直到$thing1或$thing2中任何一个准备好, 它将返回一个包含socket的数组. (如果它们都准备好了,@ready将包含两个socket.) 一旦有了准备好的socket, 我们一个一个地读取数据找出它们发送的是是什么:

   for $socket (@ready) {
        $socket->recv($line,80);
        if($line eq "") { die "they hung up on me"; }
        print "someone sent $line.  Sending it back.\n";
        $socket->send($line) or die "hey, where did they go?";
   }

现在我们有足够的片段来写我们的第一个聊天服务程序. 这个聊天室里的交谈没有什么意思,除非你中意和自己聊天 - 服务程序会把你说的全部回送. 但它将告诉你如果结合socket和select()来建立一个一个时刻只能做一件事的服务器.下面是程序源码:

#!/usr/local/bin/perl -wT
require 5.002;
use strict;
use IO::Socket;
use IO::Select;

#创建一个socket然后监听一个端口
my $listen = IO::Socket::INET->new(Proto => 'tcp',
   LocalPort => 2323,
   Listen => 1,
   Reuse => 1) or die $!;

# 开始$select只包含我们监听的socket
my $select = IO::Select->new($listen);

my @ready;

#等待,直到有事情发生
while(@ready = $select->can_read) {

    my $socket;

    # 处理每个准备好了的socket
    for $socket (@ready) {

# 如果被监听的socket准备好了,接收一个新的连接
if($socket == $listen) {
    my $new = $listen->accept;
    $select->add($new);
    print $new->fileno . ": connected\n";
} else {

    # 否则读入一行文字,然后发送回去
    my $line="";
    $socket->recv($line,80);
    $line ne "" and $socket->send($line) or do {

# 如果没有什么可发送和接收的,中断连接
print $socket->fileno . ": disconnected\n";
$select->remove($socket);
$socket->close;
    };
}
    }
}



广播:

接下来的工作是把聊天信息发送给所有的用户(不光是你自己),也就是所谓"广播".

我们可以用$select, 它new()或add()来返回所有给$select的sockets,从而得知"所有用户"到底是谁.我们来修改下程序:


            $socket->recv($line,80);
            if($line eq "") {
                print $socket->fileno . ": disconnected\n";
                $select->remove($socket);
                $socket->close;
            };
            my $socket;

            # 向所有用户广播.如果send()失败了就关闭连接.
            
            for $socket ($select->handles) {
                next if($socket==$listen);
                $socket->send($line) or do {
                    print $socket->fileno . ": disconnected\n";        
                    $select->remove($socket);
                    $socket->close;
                };
            }

下面是这个聊天程序的所有代码:


#!/usr/local/bin/perl -wT
require 5.002;
use strict;
use IO::Socket;
use IO::Select;

#创建一个socket监听端口
my $listen = IO::Socket::INET->new(Proto => 'tcp',
   LocalPort => 2323,
   Listen => 1,
   Reuse => 1) or die $!;

#$select只包含我们正在监听的socket
my $select = IO::Select->new($listen);

my @ready;

# 等待
while(@ready = $select->can_read) {

    my $socket;

    # 处理每个准备好的端口
    for $socket (@ready) {

# 如果被监听的端口准备好,接收一个新的连接
if($socket == $listen) {
    my $new = $listen->accept;
    $select->add($new);
    print $new->fileno . ": connected\n";
} else {

    # 读入一行文字
    # 如果recv()失败,关闭连接
    my $line="";
    $socket->recv($line,80);
    if($line eq "") {
print $socket->fileno . ": disconnected\n";
$select->remove($socket);
$socket->close;
    };
    my $socket;

    # 向所有人广播,如果send()失败则关闭连接.
    for $socket ($select->handles) {
next if($socket==$listen);
$socket->send($line) or do {
    print $socket->fileno . ": disconnected\n";
    $select->remove($socket);
    $socket->close;
};
    }
}
    }
}

1;
            


我是谁?



我们的聊天程序还有一个问题,就是我们不知道是谁在说话.真正的聊天室服务器能让你知道谁是谁,在发言后面把他们的名字显示出来.

如果我们只能在一个时刻做一件事情,请求一个handle的较为直接的程序代码就象这个样子:

         my $new = $listen->accept;
            $select->add($new);
            print $new->fileno . ": connected\n";
            $new->write("choose a handle> ");
            $handle[$new->fileno] = $new->recv;
            

问题是,我们不能要服务器停下来等待用户输入,我们需要把用户在那里的信息保存下来,当一个用户在输入的时候,可以处理其他用户,当这个用户输入完了以后在回来.完成这些功能的代码可以分为两部分:

sub login {
            my($new) = @_;
            $select->add($new);
            print $new->fileno . ": connected\n";
            $new->write("choose a handle> ");
            save_where_we_are();
        }

        sub get_handle {
            my($socket) = @_;
            $handle[$socket->fileno] = $socket->recv;
        }
        
#!/usr/local/bin/perl -wT
require 5.002;
use strict;
use IO::Socket;
use IO::Select;

my $port = scalar(@ARGV)>0 ? $ARGV[0] : 2323;

$| = 1;
my $listen = IO::Socket::INET->new(Proto => 'tcp',
   LocalPort => $port,
   Listen => 1,
   Reuse => 1) or die $!;
$ENV{'PATH'} = "/usr/bin";
my $date = `date`;
warn "started on $port on $date";
my $select = IO::Select->new($listen);
my @chatters;

# 在win32中,注释掉下面这句
$SIG{'PIPE'} = 'IGNORE';

my @ready;
while(@ready = $select->can_read) {
    print "going: ".join(', ',map {$_->fileno} @ready) . "\n";
    my $socket;
    for $socket (@ready) {
if($socket == $listen) {
    my $new_socket = $listen->accept;
    Chatter->new($new_socket, $select, \@chatters);
} else {
    my $chatter = $chatters[$socket->fileno];
    if(defined $chatter) {
&{$chatter->nextsub}();
    } else {
print "unknown chatter\n";
    }
}
    }
}

package Chatter;
use strict;

sub new {
    my($class,$socket,$select,$chatters) = @_;

    my $self = {
'socket' => $socket,
'select' => $select,
'chatters' => $chatters
};
    bless $self,$class;

    $chatters->[$socket->fileno] = $self;
    $self->select->add($socket);

    $self->log("connected");
    $self->ask_for_handle;

    return $self;
}

sub socket { $_[0]->{'socket'} }
sub select { $_[0]->{'select'} }
sub chatters { $_[0]->{'chatters'} }
sub handle { $_[0]->{'handle'} }
sub nextsub { $_[0]->{'nextsub'} }

sub ask_for_handle {
    my($self) = @_;
    my $welcome =<< END;

欢迎你来到我的聊天室.

使用指南:
请注意这个聊天室程序不完全兼容telnet协议,所以有些telnet客户端程序可能不工作,抱歉!
如果你输入的字符都分行显示,请退出然后试一试其它的telnet客户端程序,最好发一个电子邮件
(bslesins-code\@hotwired.com)告诉我你用的是什么程序.

我们已经试过下面的客户端程序,它们都能很好的工作:
  - "telnet" on Solaris
  - "telnet" on IRIX
  - CRT on Windows 95
我们已经收到报告,微软的Telnet不能工作.

另外,有些人登录以后可能去干别的事情了,所以他们不会马上看到你的信息.所以输入以后,保持telnet
窗口开着,等待一会儿.

关闭你的telnet窗口就可以退出.或者假如你是在Unix命令行运行telnet的话,按Control-]然后在提示中按"close"键.

__Brian__

END
    $welcome =~ s:\n:\r\n:g;
    $self->write($welcome);

    $self->write("choose a handle> ");

    $self->{'nextsub'} = sub { $self->get_handle };
}

sub get_handle {
    my($self) = @_;

    my $handle = $self->read or return;
    $handle =~ tr/ -~//cd;
    $self->{'handle'} = $handle;
    $self->broadcast("[$handle is here]");
    $self->log("handle: $handle");
    $self->{'nextsub'} = sub { $self->chat };
}

sub chat {
    my($self) = @_;

    my $line = $self->read;
    return if($line eq "");
    $line =~ tr/ -~//cd;
    my $handle = $self->handle;
    $self->broadcast("$handle> $line");
}

sub broadcast {
    my($self,$msg) = @_;

    my $socket;
    for $socket ($self->select->handles) {
my $chatter = $self->chatters->[$socket->fileno];
$chatter->write("$msg\r\n") if(defined $chatter);
    }
}

sub read {
    my($self) = @_;

    my $buf="";
    $self->socket->recv($buf,80);
    $self->leave if($buf eq "");
    return $buf;
}

sub write {
    my($self,$buf) = @_;
    $self->socket->send($buf) or $self->leave;
}

sub leave {
    my($self) = @_;

    print "leave called\n";

    $self->chatters->[$self->socket->fileno] = undef;
    $self->select->remove($self->socket);
    my $handle = $self->handle;
    $self->broadcast("[$handle left]") if(defined $handle);
    $self->log("disconnected");
    $self->socket->close;
}

sub log {
    my($self,$msg) = @_;
    my $fileno = $self->socket->fileno;
    print "$fileno: $msg\n";
}

__END__

# and here's a chat server in 4 lines :-)

#!/usr/local/bin/perl -- minchat: run and telnet to port 5555 - bslesins
sub p{print@_}$SIG{CHLD}=sub{wait};socket S,2,2,6;bind S,pack(Snx12,2,5555);
listen S,5;while(accept C,S){if(!fork){open(STDOUT,">&C");p"name:";$n=substr
,0,-2;$f=fork||exec"tail -f chatlog";open W,">>chatlog";select(W);$|=1;p
"[$n here]\r\n";while(){p"$n> $_";}p"[$n gone]\r\n";kill 15,$f;exit}}



如何保存用户位置信息呢? 一个方法是保存一个子程序的指针,而这个子例程包含了下一步该做什么:

$nextsub[$socket->fileno] = &get_handle;

这样我们就可以在@nextsub中适当的入口找到我们出发的位置. 综合以上所述,我们把程序整理如下.





剩下的工作:

我们的聊天室程序还不是一个完整的作品,如果你象把它放在你的服务器上工作,还有许多事情要做.他们是:

输入缓冲区: 关于recv()函数,它并不总是每次接收一行数据.一个真正的聊天服务器需要把recv()的结果添加到缓冲区中,并找到折行字符,把它分成几行.

输出缓冲区: 如果有人挂起它的telnet进程太长时间,调用send()会中断它.但可以用select()来发现一个socket是否已经准备好.

更好地支持telnet协议

加入常用的命令:帮助,列出在聊天室中的用户名单,退出等等

用户账号密码保护

多个聊天房间

权限控制

私人聊天房间

等等...

最近一直有在学习POE，这是一个类似于状态机的网络框架，在python上有叫twisted的类似框架。为此也看了一些文章，并学习了一些例子。
对 于SOCKET编程，也许是很久没有用了的缘故，看到相关的一段程序时，感觉相当地眼生。还因为之前一直是用perl原生的socket命令来写的，所以 对IO::Socket没有做过多的了解。再去看书，或者将perldoc里的内容从头到尾地通读一遍，一来没有什么兴趣，二来就以往经验来看很多内容都 是很少用到的，看了也容易忘记。所以就将这段代码抄了一遍，对于其中不了解或者有疑问的再去查perldoc，或者写一些测试代码来验证。事实证明收获也 是不小，很快就了解了其中的主要内容，顺带地还将POSIX中的一些常量搞搞清楚。更重要的是在抄写这样规范的代码，对于自身编写程序的格式也会有潜移默 化的影响。
这么做的关键在于，首先要有一段好的代码，第二不要抱着得过且过的心态放过一些细节。

#!/usr/bin/perl

use warnings;
use strict;

use POSIX;
use IO::Socket;
use IO::Select;
use Tie::RefHash;

# Create the server socket.

my $server = IO::Socket::INET->new(
        LocalPort => 12345,
        Listen => 10,
    ) or die "can't make server socket: $@\n";
    
$server->blocking(0);

# Set structures to track input and output data.

my %inbuffer = ();
my %outbuffer = ();
my %ready = ();

tie %ready, "Tie::RefHash";

# The select loop itself.

$my select = IO::Select->new($server);

while(1) {
    
    # Process sockets that are ready for reading.
    foreach my $client( $select->can_read(1) ) {
        handle_read($client);
    }
    
    # Process any complete requests. Echo the data back to the client,
    # by putting the ready lines into the client's output buffer.
    foreach my $client ( keys %ready ) {
        foreach my $request ( @{ $ready{$client} } ) {
            print "Got request: $request\n";
            $outbuffer{$client} .= $request;
        }
        delete $ready{$client};
    }
    
    # Process sockets that are ready for writing.
    foreach my $client ( $server->can_write(1) ) {
        handle_write($client);
    }
}

exit;

# Handle a socket that's ready to be read from.

sub handle_read {
    my $client = shift;
    
    # If it's the server socket, accept a new client connection.
    if ( $client == $server ) {
        my $new_client = $server->accept();
        $new_client->blocking(0);
        $select->add($new_client);
        return;
    }
    
    # Read from an established client socket.
    my $data = "";
    my $rv = $client->recv( $data, POSIX::BUFSIZ, 0 );
    
    # Handle socket errors.
    unless ( defined($rv) and length($data) ) {
        handle_error($client);
        return;
    }
    
    # Successful read. Buffer the data we got, and parse it into lines.
    # Place the lines into %ready, where they will be processed later.
    $inbuffer($client) .= $data;
    while ( $inbuffer{$client} =~ s/(.*\n)// ) {
        push @{ $ready{$client} }, $1;
    }
}

# Handle a socket that's ready to be write to.

sub handle_write {
    my $client = shift;
    
    # Skip this client if there's nothing write.
    return unless exists $outbuffer{$client};
    
    # Attempt to write pending data to the client.
    my $rv = $client->send( $outbuffer{$client}, 0 );
    unless ( defined $rv ) {
        warn "I was told I could write, but I can't.\n";
        return;
    }
    
    # Successful write. Remove what was sent from the output buffer.
    if ( $rv == length( $outbuffer{$client} ) or $! ==POSIX::EWORLDBLOCK ) {
        substr( $outbuffer($client), 0, $rv ) = "";
        delete $outbuffer{$client} unless length $outbuffer{$client};
        return;
    }
    
    # Otherwise there was an error.
    handle_error($client);
}

# Handle client error. Clean up after dead socket.
sub handle_error {
    my $client = shift;
    
    delete $inbuffer{$client};
    delete $outbuffer{$client};
    delete $ready{$client};
    
    $select->remove($client);
    close $client;
}

PERL灵活的进程函数是为了复制进程用于分担任务与程序的工作量。

PERL中复制进程有两种方法：fork()、system()与exec()。

━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

fork()部分:*NIX传统的复制进程方法

==============================================================

fork()函数:

作用:进程复制函数。

用法:$pid=fork();

讲解:

无参数；当本进程为父进程时返回值为子进程的PID值，当进程为子进程时返回值为0。

实例:

#!usr/bin/perl -w

$pid=fork(); #复制进程，并把返回值附入$pid

die "Error:$!\n" unless defined $pid; #制定程序的错误机制，此步可略

if($pid!=0){ #条件选择，测试$pid值

print"This is a main pid!PID is $$!\n"; #$pid值不等于0，此为父进程(附:$$为保留变量，其值为此进程的PID)

}else{ #否则.....

print"This is a sub pid!PID is $$!\n"; #$pid值为0，此为子进程

}

exit 1; #退出程序

分析实例:

楼上的程序没有父进程与子进程的明显分化，要将它们分开就要靠测试$pid的值，所以对fork()函数的调用来说条件语句是非常重要的，需要通过它们来辨别fork() 的返回值。

±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±

getppid()函数:

作用:在子进程中调用此函数来获得父进程PID值。

用法:$parent=getppid();

讲解:无参数，调用后其返回值为父进程的PID值。

实例:

#!usr/bin/perl -w

$pid=fork(); #复制进程

die "Error:$!\n" unless defined $pid; #制定错误机制，此步可略

if($pid==0){ #当进程为子进程则进入条件，当进程为父进程则跳过到程序结束

$parent=getppid(); #通过getppid()得到父进程PID值

print"This is a sub pid:$$,the parent is $parent\n"; #在STDOUT打印子进程PID值与其父进程ID值

}

exit 1; #退出程序

注意:楼上的getppid()实例无法在WIN32下通过，建议使用*nix平台。

±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±

关于使用fork():通过fork()创建的子进程共享了父进程的所有变量、句柄等当前值。

━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

system()与exec()部分:更直观的进程调用

=============================================================

system()函数:

作用:直接生成子进程。

用法:$result=system("dir/w *.bat"); 或 $result=system("dir/w","*.bat");

讲解:参数为SHELL语句。当函数能正常调用时返回值为0(注意:此与其他函数不一致)，其他返回值均为错误。

实例:

#!usr/bin/perl -w

print STDOUT system("dir/w","*.pl"); #把system()函数中的子进程SHELL语句"dir/w *.pl"的结果输出到STDOUT中

exit 1; #退出程序

#在c:\根目录下运行结果为:

C:\>perl mm.pl

驱动器 C 中的卷没有标签。

卷的序列号是 2629-08EF

C:\ 的目录

aaa.pl bbb.pl zzz.pl xxx.pl SOCK.PL

connect.pl connect2.pl connect3.pl connect4.pl connect5.pl

connect6.pl connect7.pl udpc.pl udps.pl connect8.pl

connect10.pl fork.pl pidd.pl mm.pl

19 个文件 7,503 字节

0 个目录 5,514,014,720 可用字节

0

#注意楼上最后的"0"，这就是返回后的数值，楼上表示程序正常调用了system()函数中的shell语句了。  

±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±

exec()函数:

作用:以指定的SHELL语句代替原进程。

用法:$result=exec("copy *.bat c:\"); 或 $result=exec("copy","*.bat","c:\");

讲解:参数为SHELL语句，成功调用后返回值为undef，其他返回值均为失败。使用此函数后生成的新进程与原进程为同一进程，

有相同的PID，共享变量语柄等一切当前值。

实例与system()相当，所以不作讨论了。

━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

附:关于"Perl的管道"部分内容博大精深，而本人又水平有限，所以只好草草了事，如果有哪里不妥还望各位前辈指点

管道是为了使不同进程可以进行通信的制定的。管道是*NIX编程的重点。

与其相关的函数有:open()、pipe()等等。

open():作打开句柄用。

格式:open(FILEHANDLE,"符号+参数");

例子:open(NIX,"|wc -lw"); #打开名为NIX的管道，其进程为‘wc -lw’，管道为写入。

open(DDD,"dir c:\|"); #打开名为DDD的管道，其进程为‘dir c:\’，管道为读取。

讲解:FILEHANDLE(句柄)包括很多成分，如文件句柄、SOCKET句柄、管道句柄，此文只谈到管道句柄。

第二个参数为双引号或单引号相括着的管道符号与参数。管道符号为"|"，把管道符号放到参数的左边为‘只读’，放到右边为‘只写’，如果两边都有便为双向管道(既可读也可写)。

简单的管道实例:

#!usr/bin/perl -w

open(AAA,"dir d:|"); #打开管道AAA,进程为"dir d:"，只读

@bbb=<AAA>; #从管道中读取内容，并压入@bbb数组

print"@bbb\n"; #把@bbb数组全部输出到STDOUT

close AAA; #关闭管道AAA

exit 1; #退出程序

〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

pipe():创建管道对。

格式: pipe(READ,WRITE);

实例:pipe(README,WRITEME); #创建了一个管道对，"README"用于读，"WRITEME"用于写。

$aaa=pipe(AAA,BBB); #创建了一个管道对，"AAA"用于读，"BBB"用于写，$aaa变量为调用pipe()的返回值。

讲解:正常调用后返回值为非零数，第一个参数为被创建的读管道，第二个参数为被创建的写管道。此函数通常配合进程中

的fork()函数一同使用，步骤是先使用pipe()函数建立管道对，再使用fork()创建新进程，在不同的进程关闭不同的

管道，这样就可以达到管道间通信的目的了。

〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

close():关闭管道

格式: close(AAA);

close BBB;

实例与格式相当，也就不详细介绍了。

讲解:close()在调用时能将子程序的终止代码放到特殊变量$?中；当关闭的是写管道时close()调用将进入堵塞状态直至另一

端完成它的全部工作为止。

信号其实就是编程里俗称的中断，它使监视与控制其他进程变为有可能。

首先说说通用信号，通用信号归纳起来可以组成以下列表:

=============================================================

信号名 值 标注 解释

------------------------------------------------------------------------

HUP 1 A 检测到挂起

INT 2 A 来自键盘的中断

QUIT 3 A 来自键盘的停止

ILL 4 A 非法指令

ABRT 6 C 失败

FPE 8 C 浮点异常

KILL 9 AF 终端信号

USR1 10 A 用户定义的信号1

SEGV 11 C 非法内存访问

USR2 12 A 用户定义的信号2

PIPE 13 A 写往没有读取者的管道

ALRM 14 A 来自闹钟的定时器信号

TERM 15 A 终端信号

CHLD 17 B 子进程终止

CONT 18 E 如果被停止则继续

STOP 19 DF 停止进程

TSTP 20 D tty键入的停止命令

TTIN 21 D 对后台进程的tty输入

TTOU 22 D 对后台进程的tty输出

------------------------------------------------------------------------

著明:上表中‘值’列下没有列出的值所对应的信号为系统调用的非标准信号，在此

文不予以探讨。上表中的第三列‘标注’定义了当进程接受到信号后的操作，

如:

A-----终止进程

B-----忽略进程信号

C-----终止进程并卸下内核

D-----停止进程

E-----恢复进程

F-----不能截取或忽略进程信号

=============================================================

下面就以INT作范例演示一下调用过程吧:

#!usr/bin/perl -w

#c:\test11.pl

my $aaa=0; #对计数器变量$aaa进行负值

while($aaa<3){ #进入循环体

print"Begin\n"; #打印字符串到STDOUT

sleep(5); #睡眠函数，参数为5秒

next unless $SIG{INT}=\&demon; #选择结构，demon子程序值负于中断函数

}

sub demon{ #demon子程序体

$aaa++; #计数器自加

print"Stop!\n"; #打印字符串到STDOUT

}

exit 1; #退出程序

输出结果:在SHELL里不停的打印出"Begin"字样，相隔5秒，一但在键盘中执行程序

中断操作(Control+"c")，屏幕就会打印出"Stop!"字样，不停地继续下去。

中断调用总结:调用需要使用到系统保留全局HASH数组%SIG，即使用"$SIG{信号名}"

截取信号，截取后将其负某个代码(子函数)的地址值，这代码就是截

取后要执行的结果了。

What Is POE, And Why Should I Use It?
    回顾一下我们每天写的程序，可以发现这些程序大部分都有着基本的结构：启动，执行一系列的动作，然后退出。对于那些在用户和他们的数据之间不需要很多交互的应用中，这样的程序都能工作得很好。然后，如果是如果是碰到了复杂的任务，我想你就需要一个更加好的程序框架理解任务的复杂性，完成这个任务。
    所以POE（Perl 对象环境）应运而生了。POE是一个构建Perl程序的框架，以更自然地完成那些需要对外部数据作出反应的任务，比如网络通讯或者用户接口。用POE写的程序完全是非线性的；你只需要建立一些小的子程序，并且定义好它们之间如何相互调用，那么POE就会根据程序处理的输入输出，自动在它们之间切换。说到现在，你可能已经头晕了。如果你习惯于看代码去理解，那么看了下面一个小例子后，你就会恍然大悟了。

POE Design
    说POE是一个小的操作系统一点都不夸张，它有它自己的内核，进程，进程间通讯（IPC），驱动等等这些。实际上，它是一个简单的系统，构建了一系列的状态信息。下面对组成POE各个部分的一个简单的描述：
States
    POE的基本程序块就是状态，它是一些代码，当事件发生时触发执行。例如，输入的数据到达，一个会话过期，一个会话传递了一条信息给另一个会话。POE里的每件事情都是基于接收和处理各种各样的事件。
The Kernel
    POE的内核跟操作系统的内核很象：它守护着后台的所有你的进程和数据，安排你的代码的触发。你能够用POE的内核来为你的进程设置警报，控制你的状态队列和其他一些低级服务，当然，大部分时间你不用直接来跟内核交互。
Sessions
    POE里的会话相当于一个真的操作系统里的进程。一个会话就是一个POE程序，当它在运行时不停地在状态之间切换。它能够创建子会话，传递信息给其他的会话等等。每个会话都能通过调用 heap 存储会话特有的数据，这些数据在会话中的各个状态都是可以存取的。
    POE有一个简单的协作的多任务处理模块；每个会话在同一个OS进程中执行，不需要任何线程和进程。对于这样的会话，你应该特别注意在POE程序中使用模块化的系统调用。
    这些就是POE的最基本的部分，但是在我们开始实际的代码前还需要稍微ie解释一些高级的POE的部分。
Drivers
    驱动位于POE最低级的I/O层。目前，只有一个驱动包括在POE的安装中-- POE::Driver::SysRW，它读写文件句柄中的数据。不管怎样，我们都不需要直接使用驱动。
Filters
    过滤器，在某个方面来说，是非常有用的。过滤器是一个简单的接口，转换数据块从一个格式成另一个格式。例如，POE::Filter::HTTPD 能够在 HTTP 1.0 requests 之间 HTTP::Request 对象互相转换。POE::Filter::Line 能够见数据流转换成序列化数据行。
Wheels
    Wheels包含了每天任务的可重复利用的高级逻辑部分。它们是POE封装有用代码的方法。在POE中你需要处理到的Wheels包括事件驱动的输入输出数据和网络连接的创建。Wheels经常使用过滤器和驱动来处理和传递数据。这个描述太过于含糊了，下面的代码将会给出一个例子来说明这个概念。
Components
    组件是一个会话，被设计来受控于其它会话。你的会话能够从它们那里来处理命令和接受事件，这点很象真实操作系统中的通过IPC通讯。一个组件的例子就是POE::Component::IRC，一个创建基于POE的IPC客户端接口，或者是POE::Component::Client::HTTP，一个事件驱动的Perl实现的HTTP用户代理。组件同样是POE非常有用的一个部分。

A Simple Example
    在这个例子中，我们会建立一个守护进程服务端，它接受TCP连接，同时打印由它的客户端提交的算术问题的答案。当有人连接它的端口31008，它将打印“Hello,client”。客户端能够提交一个算术表达式，以一个新行结束提交，服务端将送回表达式的答案。够简单吧。
    写这样一个POE程序跟写一个Unix下的守护进程的传统方法没有什么很大的不同。我们将有一个服务器会话在端口31008监听TCP连接。每当连接到来时，它将创建一个子会话来处理连接。每个子会话都能跟用户交互，然后在连接断开后安静地死掉。所有这些用Perl简单地实现只需要模块化的72行代码就行了。
    这个程序简单地以下面的代码开始：
   1  #!/usr/bin/perl -w
   2  use strict;
   3  use Socket qw(inet_ntoa);
   4  use POE qw( Wheel::SocketFactory  Wheel::ReadWrite
   5              Filter::Line          Driver::SysRW );
   6  use constant PORT => 31008;
这一段我们导入了脚本所需要的模块以及函数，并定义了监听端口的常量值。”use POE;”后面的 qw()语句一次导入了很多POE::模块。
    现在开始本文最酷的部分：
   7  new POE::Session (
   8      _start => \&server_start,
   9      _stop  => \&server_stop,
  10  );
  11  $poe_kernel->run();
  12  exit;
    这样就已经是一个完整的程序了！我建立了服务端会话，告诉POE内核开始执行事件，并且在事件结束后退出。（当没有任何会话需要管理的时候，POE内核就认为事情做完了，但是既然我们已经打算把服务端会话放在一个无穷的循环中，它将不会以这种发式退出）POE在你写"use POE;"h后，自动输出变量$poe_kernel 到你的名字空间中。
    new POE::Session 方法调用需要解释一下。当你创建一个会话时，你给内核一个这个会话将接受事件的列表。在上面的代码中，意味着这个新的会话将通过调用&server_start，&server_stop处理_start和_stop事件。任何一个受到的但没有列举到的事件，将会被会话忽略。_Start和_Stop事件对于一个POE会话来说是一个特殊事件。_start事件是当一个会话创建时第一件要做的事情，当会话将要被摧毁时内核就通知这个会话进入_stop状态。
    现在，我们已经写了完整的程序，我们还要写当会话运行时要执行的状态代码。接下来，让我们以&server_start开始。当主要的服务端会话被创建，开始执行程序时，它将会被调用。

  13  sub server_start {
  14      $_[HEAP]->{listener} = new POE::Wheel::SocketFactory
  15        ( BindPort     => PORT,
  16          Reuse        => 'yes',
  17          SuccessState => \&accept_new_client,
  18          FailureState => \&accept_failed
  19        );
  20      print "SERVER: Started listening on port ", PORT, ".\n";
  21  }

    这是一个有关POE状态的很好的例子。首先：看到变量$_[HEAP]了吗？POE有一个特殊的方法来传递参数。@_数组是由许多外部的参数打包在一起的。外部参数包括目前内核，会话和状态名的一个引用，堆栈的引用，以及其它一些东西。我们可以用POE导出的特殊常量来作为这个数组索引，比如 HEAP, SESSION, KERNEL, STATE和ARG0~ARG9（用户提供的参数）。跟POE的大部分设计一样，这样子的安排能够最大化后面的兼容性而又不牺牲速度。上面的例子存储了一个 SocketFactory wheel 在键值 listen 下。
    POE::Wheel::SocketFactory wheel是POE里最酷的东西之一。你能够用它创建任何一个流socket（UDP socket还不行），而不需要担心细节。上面的代码将创建一个SocketFactory来监听特殊的TCP端口的新连接。当连接建立时，它将调用&accept_new_client来传递一个新的客户端，如果在这其中发生错误了，它将调用&accept_failed，而不是让我们自己来处理错误。这差不多就是用POE在网络中要做的。
    我们存储一个wheel在堆栈中，以防止在状态的最后被Perl的垃圾收集机制意外地消灭掉，——这个方法在会话的每个状态中到处存在。现在我们来看&server_stop 状态的代码：

  22  sub server_stop {
  23      print "SERVER: Stopped.\n";
  24  }


这段不需要多解释了。接下来的是我们创建一个新的会话来处理每个新到的连接。

  25  sub accept_new_client {
  26      my ($socket, $peeraddr, $peerport) = @_[ARG0 .. ARG2];
  27      $peeraddr = inet_ntoa($peeraddr);
  28      new POE::Session (
  29          _start => \&child_start,
  30          _stop  => \&child_stop,
  31          main   => [ 'child_input', 'child_done', 'child_error' ],
  32          [ $socket, $peeraddr, $peerport ]
  33      );
  34      print "SERVER: Got connection from $peeraddr:$peerport.\n";
  35  }
当客户端成功地建立了跟服务端的连接后，我们的 POE::Wheel::SocketFactory将调用这个子例程。
我们将socket地址转换成人可读的IP地址，并且建立一个新的会话来跟客户端通讯。这跟前面的 
POE::Session 构造器很象，但是有几点在接下来要说明。
    @_[ARG0 .. ARG2]是($_[ARG0], $_[ARG1], $_[ARG2])的快捷方式。你会在POE程序中
看到很多这样的数组切片。
    看31行：好像有点奇怪，其实这是一种很聪明的缩写。它可以用下面的比较长的方法来重写：
  new POE::Session (
      ...
      child_input => &main::child_input,
      child_done  => &main::child_done,
      child_error => &main::child_error,
      ...
  );
    这是一个方便的做法来写出很多的状态名字，这些名字跟事件的名字是一样的。——你可以传递包名或者
对象来作为键，或者是任何一个有子例程，方法名组成的数组引用。可以参考POE::Session得到更多的信息。
    最后，在POE::Session 构造器参数列表最后的数组引用是我们要手动传递给_start状态的参数列表。
    如果POE::Wheel::SocketFactory在创建监听端口或者接受连接时产生了问题，下面的会发生：
  36  sub accept_failed {
  37      my ($function, $error) = @_[ARG0, ARG2];
  38      delete $_[HEAP]->{listener};
  39      print "SERVER: call to $function() failed: $error.\n";
  40  }

    打印错误信息是正常的处理方式，但是我们为什么还要从堆栈中删除SocketFactory wheel呢？答案在于
POE管理会话资源的方式。只要会话还能产生和接受事件，那么它就被认为是活动的。如果没有wheel，POE内核
会认为会话已经死了，并收集会话的资源。服务端得到事件的唯一方式就是从SocketFactory wheel，如果
它被消灭了，POE内核会一直等待，直到所有它的子会话结束，再收集所有占用的资源。在这一点上，既然
已经没有剩下的会话需要执行，POE内核将会结束并退出。
    所以，基本上来说，这是最通常的结束POE会话的方法：结束所有会话资源，让内核干剩下的工作。现在，
我们谈到子会话的细节。
    
  41  sub child_start {
  42      my ($heap, $socket) = @_[HEAP, ARG0];
  43      $heap->{readwrite} = new POE::Wheel::ReadWrite
  44        ( Handle => $socket,
  45          Driver => new POE::Driver::SysRW (),
  46          Filter => new POE::Filter::Line (),
  47          InputState => 'child_input',
  48          ErrorState => 'child_error',
  49        );
  50      $heap->{readwrite}->put( "Hello, client!" );
  51      $heap->{peername} = join ':', @_[ARG1, ARG2];
  52      print "CHILD: Connected to $heap->{peername}.\n";
  53  }
    每当新的子会话被创建来处理最新的连接客户端时上面的代码就会被调用。这里我们要介绍一种新的
POE wheel：ReadWrite wheel，这是一个由事件驱动的处理I/O任务的wheel。我们把它传递给文件
句柄，一个驱动，一个过滤器等等。接着，每当新的数据到达文件句柄时，wheel将发送一个child_input
事件给会话，如果有任何错误发生就会发送一个child_error 事件。
    我们理解用这个新的wheel来输出字符串”Hello,client”给socket。最后，我们存储在堆栈中
的客户端地址和端口，并打印成功信息。
    我们省略了 child_stop 的状态讨论。它只有一行长度。现在我们直接看主要的child_input 程序。
  57  sub child_input {
  58      my $data = $_[ARG0];
  59      $data =~ tr{0-9+*/()-}{}cd;
  60      return unless length $data;
  61      my $result = eval $data;
  62      chomp $@;
  63      $_[HEAP]->{readwrite}->put( $@ || $result );
  64      print "CHILD: Got input from peer: \"$data\" = $result.\n";
  65  }
    当客户端发送给我们一行数据，我们取得里面简单的算术表达式并eval它，然后把结果或者错误信息
发送给客户端。通常情况下，将客户端发送来的不可信任的数据直接就eval是非常危险的，所以我们要确保
在eval前，将字符串中所有的非数学字符全部过滤掉。子会话将一直保持接受数据直到客户端断开。
    所有事件驱动的应用都是使用POE的好地方。
源代码：http://www.perl.com/2001/01/poe-math3.pl

日志统计分析软件Awstats需要Perl支持，但是Nginx内建的Perl模块目前还并不稳定，经常会出问题，所以还是用FastCGI模式运行Perl比较可靠。下面就谈谈如何在Nginx下配置Perl的FastCGI模式：

首先，安装Perl的FastCGI模块：

#wget http://www.cpan.org/modules/by-module/FCGI/FCGI-0.67.tar.gz
#tar zxvf FCGI-0.67.tar.gz
#cd FCGI-0.67
# perl Makefile.PL
#make && make install

其实也可以用这种方法：#perl -MCPAN -e ‘install FCGI’

然后，配置Perl的FastCGI脚本（从网上找到的，未找到原始出处）：

#!/usr/bin/perl
use FCGI;
use Socket;
use POSIX qw(setsid);
require ’syscall.ph’;
&daemonize;
END() { } BEGIN() { }
*CORE::GLOBAL::exit = sub { die “fakeexit\nrc=”.shift().”\n”; };
eval q{exit};
if ($@) {
exit unless $@ =~ /^fakeexit/;
};
&main;
sub daemonize() {
chdir ‘/’ or die “Can’t chdir to /: $!”;
defined(my $pid = fork) or die “Can’t fork: $!”;
exit if $pid;
setsid or die “Can’t start a new session: $!”;
umask 0;
}
sub main {
$socket = FCGI::OpenSocket( “/tmp/perl_fastcgi.sock”, 10 );
$request = FCGI::Request( \*STDIN, \*STDOUT, \*STDERR, \%req_params, $socket );
if ($request) { request_loop()};
FCGI::CloseSocket( $socket );
}
sub request_loop {
while( $request->Accept() >= 0 ) {
$stdin_passthrough =”;
$req_len = 0 + $req_params{’CONTENT_LENGTH’};
if (($req_params{’REQUEST_METHOD’} eq ‘POST’) && ($req_len != 0) ){
my $bytes_read = 0;
while ($bytes_read < $req_len) {
my $data = '';
my $bytes = read(STDIN, $data, ($req_len - $bytes_read));
last if ($bytes == 0 || !defined($bytes));
$stdin_passthrough .= $data;
$bytes_read += $bytes;
}
}
if ( (-x $req_params{SCRIPT_FILENAME}) &&
(-s $req_params{SCRIPT_FILENAME}) &&
(-r $req_params{SCRIPT_FILENAME})
){
pipe(CHILD_RD, PARENT_WR);
my $pid = open(KID_TO_READ, "-|");
unless(defined($pid)) {
print("Content-type: text/plain\r\n\r\n");
print "Error: CGI app returned no output - Executing $req_params{SCRIPT_FILENAME} failed !\n";
next;
}
if ($pid > 0) {
close(CHILD_RD);
print PARENT_WR $stdin_passthrough;
close(PARENT_WR);
while(my $s = ) { print $s; }
close KID_TO_READ;
waitpid($pid, 0);
} else {
foreach $key ( keys %req_params){
$ENV{$key} = $req_params{$key};
}
if ($req_params{SCRIPT_FILENAME} =~ /^(.*)\/[^\/]+$/) {
chdir $1;
}

close(PARENT_WR);
close(STDIN);
syscall(&SYS_dup2, fileno(CHILD_RD), 0);
exec($req_params{SCRIPT_FILENAME});
die(”exec failed”);
}
}
else {
print(”Content-type: text/plain\r\n\r\n”);
print “Error: No such CGI app - $req_params{SCRIPT_FILENAME} may not exist or is not executable by this process.\n”;
}

}
}

将权限改为可执行，并执行之。

配置nginx.conf，使之支持perl脚本：

location ~* .*\.pl$
{
include awstats.conf;
}

编辑awstats.conf

fastcgi_pass unix:/tmp/perl_fastcgi.sock;
fastcgi_index awstats.pl;
fastcgi_param SCRIPT_FILENAME $document_root$fastcgi_script_name;
fastcgi_param QUERY_STRING $query_string;
fastcgi_param REQUEST_METHOD $request_method;
fastcgi_param CONTENT_TYPE $content_type;
fastcgi_param CONTENT_LENGTH $content_length;
fastcgi_param GATEWAY_INTERFACE CGI/1.1;
fastcgi_param SERVER_SOFTWARE nginx;
fastcgi_param SCRIPT_NAME $fastcgi_script_name;
fastcgi_param REQUEST_URI $request_uri;
fastcgi_param DOCUMENT_URI $document_uri;
fastcgi_param DOCUMENT_ROOT $document_root;
fastcgi_param SERVER_PROTOCOL $server_protocol;
fastcgi_param REMOTE_ADDR $remote_addr;
fastcgi_param REMOTE_PORT $remote_port;
fastcgi_param SERVER_ADDR $server_addr;
fastcgi_param SERVER_PORT $server_port;
fastcgi_param SERVER_NAME $server_name;
fastcgi_read_timeout 60;

然后重启nginx：
#service nginx restart