September 27, 2005
perl client for Authlib - 一个courier认证库的客户端
有时候，人懒的话，就啥事也觉得不想干不想做，觉得做起来都麻烦，一直都想做一个通过courier套件中的authlib认证用户信息的插件模块，却因懒惰而拖延。
今天，不知道哪里来的动力，翻开cyrus-sasl 2.1.19的source，看了一把，用perl简单的实现了一个courier-authlib的客户端，支持查询和修改密码。
这样这个模块应用到extmail中，就成为了目前为止第四个认证模块了。
Authdamond 认证基本原理
注意：这个所谓原理只是我看checkpw.c 粗浅的认识，详细的原理请直接在courier官方网站查找，或直接联系Mr Sam（courier作者）认证（查询信息）：
1. 客户端搜集用户名/密码，并计算查询信息总长度
2. 创建Unix socket，连接到authdaemond的socket绑定文件
3. 将查询信息总长度，服务名，login，用户名，密码等信息以新行间隔开，发送到
socket，最后以两个新行newline （回车）结束
4. 读authdaemond的返回信息，如果返回信息结尾包括"."则表示成功，否则
将返回FAIL等出错信息
5. 关闭该socket
修改密码
1. 客户端搜集用户名/密码和新密码 2. 创建Unix socket，连接到authdaemond的socket绑定文件 3. 将服务名，用户名，旧密码，新密码发送到该socket，注意与查询不同，信息之间 以\t间隔，结束以一个新行结束。 4. 检查返回结果，如果是成功则返回OK，失败则返回FAIL 5. 关闭socket
authdameond_cli.pl源码
具体代码见下文，请阅读本文的读者注意：
程序代码以GPL版权释出，作者不对代码作出任何担保，不回答有关问题，使用与否与作者无关
#!/usr/bin/perl -w
# vim: set cindent expandtab ts=4 sw=4:
#
# authdaemond_cli.pl
# ==================
# A small progarme to query/change user information via courier
# authlib, only test on courier-authlib 0.5x, use it as your risk!
#
# License: GPL v2
# Author: He zhiqiang <hzqbbc@hzqbbc.com>
# Copyright (c) 1998-2005
use IO::Socket::UNIX;
use vars qw($socket_path);
$socket_path = '/var/spool/authdaemon/socket';
usage() unless(scalar @ARGV>1);
my $sock = IO::Socket::UNIX->new($socket_path) or die "Error: $!\n";
my ($user, $pass) = ($ARGV[0], $ARGV[1]);
my ($serv, $type) = ('authdaemond', 'login');
if($ARGV[2]) {
print STDOUT "Changing password for $user ...\n";
printf($sock "PASSWD %s\t%s\t%s\t%s\n",
$serv,
$user,
$pass,
$ARGV[2]
);
print while(<$sock>);
}else {
my $len = length($user.$pass.$serv.$type)+4;
print STDOUT "Querying information for $user ...\n";
printf($sock "AUTH %s\n%s\n%s\n%s\n%s\n\n",
$len,
$serv,
$type,
$user,
$pass
);
print while(<$sock>);
}
# close the socket
$sock->shutdown(1);
# ===================== #
# small function to use #
# ======================#
sub usage {
print STDERR "$0 username passwd [newpasswd]\n";
exit(255);
}
使用方法
修改程序中$socket_path，指向系统中authdaemond绑定的socket路径（必须是全路径），假设数据库中有一个用户叫demo@extmail.dns0755.net，密码是demo，则按如下格式执行：
perl authdaemond_cli.pl demo@demo.dns0755.net demo
结果：
Querying information for demo@extmail.dns0755.net ... UID=1000 GID=1000 HOME=/home/domains/extmail.dns0755.net/demo/ ADDRESS=demo@extmail.dns0755.net NAME=demo me QUOTA=104857600S PASSWD=$1$BdJPD$oBV5a/25BAO2B8B2zOexx0 PASSWD2=demo .
修改密码则按如下格式执行：
perl authdaemond_cli.pl demo@extmail.dns0755.net demo newpwd
正常的话结果如下：
Changing password for demo@extmail.dns0755.net ... OK
该小程序还可以作为courier-authlib的authtest的一个补充，有其他需要的朋友可以在此基础上进行修改。
Posted by hzqbbc at 03:32 PM | Comments (1)
June 27, 2005
awstats auto update的方法及perl脚本
awstats是一个功能强大的日志分析工具，对于一个简单的网站而言，只需要根据awstats官方网站的帮助来安装和配置即可使用。但是如果需要服务多个网站，例如提供虚拟主机的ISP，需要统计大量的网站的话，常规的方法有点麻烦。
实现自动统计更新是一个必然的需求。实现起来也比较简单，一些shell脚本+perl脚本，配置一下crontab就差不多了。
1. 配置Apache调整日志存储方式
为每一个虚拟主机单独保存日志，这样便于统计。注意，配置的命令必须在每一个虚拟主机的配置里面，即
CustomLog /var/log/httpd/www.hzqbbc.com_log combined
2. 配置awstats 的per Host config
为每个要进行统计的虚拟主机单独配置一个配置文件，在我的awstat安装中配置文件的目录放在/etc/awstats下，每个虚拟主机的配置文件名都有如下格式（以hzqbbc.com为例):
awstats.www.hzqbbc.com.conf
每个配置文件里只需要指定几个主要参数即可。其中如下几个参数必须指定：
LogFile="/var/log/httpd/www.hzqbbc.com_log" SiteDomain="hzqbbc.com" HostAliases="www.hzqbbc.com 127.0.0.1 localhost"
3. 自动更新脚本
以下是自动更新脚本，命名为cron.pl
#!/usr/bin/perl -w
use strict;
my @list = glob("/etc/awstats/*");
for(0...scalar @list-1) {
$list[$_]=~s#.*/awstats\.([^\/]+)\.conf$#$1#;
}
foreach(@list) {
`perl awstats.pl -config=$_ -upate`;
}
exit(0);
将这个perl脚本防止在awstats的cgi-bin目录里，即/var/www/cgi-bin/awstats/wwwroot/cgi-bin里
4. 配置crontab
以root身份登陆系统，执行crontab -e，增加一条记录：
0 */3 * * * (cd /var/www/cgi-bin/awstats/wwwroot/cgi-bin/; perl cron.pl)
这里定义了每隔3小时呼叫一次cron.pl并更新日志。如果机器的负载很高，并且虚拟主机的数量巨大，那么建议每天只更新1次，并且在深夜负载低时进行。
经过上述配置后，以后新增的虚拟主机只需要简单增加一个awstats的配置即可实现自动的日志分析。访问时，只需要将URL中的config=xxx替换成相应网站名即可。
Posted by hzqbbc at 09:19 AM | Comments (1)
June 05, 2005
Mailing List （邮件列表）原理简述及我的perl实现
注： 本文本来是一早要写的，可是程序写了有段时间了，最近一段时间又很忙，居然给忘了，现在补上。
正文
大部分IT人员都使用过邮件列表，或者类似的服务，但邮件列表的内部工作原理则不是简单的订阅，退订阅那么简单。最近根据自己的一些认识，用perl实现了一个非常简单的MLM程序，也顺便谈谈邮件列表的最基本工作原理。
邮件列表，简单的来说，就是任一列表成员向该列表发的邮件，其他所有人（可以包括他自己）都能收到，并且每个人能自由订阅、退订。更丰富的邮件列表还包括了摘要，精确权限管理，web archive功能等等。
著名的开源邮件列表软件如mailman, majodomo, ezmlm, sympa, ecartis等都是功能完备的邮件列表软件，但归根结底，最简单的邮件列表至少应该包含如下功能：
- 订阅功能，即用户发特定订阅信件到邮件列表
- 确认订阅功能，即用户必须给MLM发确认信才能正式订阅
- 退订功能，用户可自由退出订阅服务。
- 任一列表成员给邮件列表发的邮件，其他人都应收到。
要实现上述的功能，如果使用perl的话并不复杂，配合Postfix MTA可以非常方便的开发出简易的邮件列表软件。以下是自己开发的MMList(Mini Mailing List) 的基本结构：
配置
基于Postfix，使用alias的方法，将邮件通过管道送到MMList：main.cf里需要配置的内容：
alias_maps = hash:/etc/postfix/aliases hash:/etc/postfix/mml.aliases virtual_alias_maps = hash:/etc/postfix/mml.virtual_alias_maps
mml.aliases的内容：
# alias file test-subscribe-hzqbbc.com: "|/usr/bin/mml -cmd=subscribe -list=test@hzqbbc.com" test-confirm-hzqbbc.com: "|/usr/bin/mml -cmd=confirm -list=test@hzqbbc.com" test-unsubscribe-hzqbbc.com: "|/usr/bin/mml -cmd=unsubscribe -list=test@hzqbbc.com"
mml.virtual_alias_maps的内容：
test-subscribe@hzqbbc.com test-subscribe-hzqbbc.com test-confirm@hzqbbc.com test-confirm-hzqbbc.com test-unsubscribe@hzqbbc.com test-unsubscribe-hzqbbc.com
MMList 的perl实现
#!/usr/bin/perl -w
# vim: set cindent expandtab ts=4 sw=4:
# MMList - a very lightweight MLM software
#
# Author: He zhiqiang <hzqbbc@hzqbbc.com>
# CopyRight (c) 1998-2005 hzqbbc.com
#
# License: GPL v2
use strict;
use Getopt::Long;
use vars qw(%cfg $cmd $list @KEY_MAP);
use vars qw($user $subj $SLOG);
$user = $subj = "";
@KEY_MAP = (
0,1,2,3,4,5,6,7,8,9,'A','B','C','D','E',
'F','G','H','I','J','K','L','M','N','O',
'P','Q','R','S','T','U','V','W','X','Y',
'Z','a','b','c','d','e','f','g','h','i',
'j','k','l','m','n','o','p','q','r','s',
't','u','v','w','x','y','z'
);
# proto-type:
# cmd ==> indicate the 'subscribe' or 'unsubscribe'
# list ==> indicate the list name
my $res = GetOptions(
"cmd=s" => \$cmd,
"list=s" => \$list
);
$cfg{'basedir'} = "/var/lib/mmlist";
$cfg{'listdir'} = $cfg{'basedir'}."/lists";
$cfg{'hostname'} = "list.hzqbbc.com";
open (MLOG, ">> $cfg{'basedir'}/mail.log");
open ($SLOG, ">> $cfg{'basedir'}/base.log");
# read from STDIN
while(<STDIN>) {
print MLOG $_;
if(/^From: (.*)$/) {
chomp;
m/([a-zA-Z0-9-_=\.]+\@[a-zA-Z0-9-_=\.]+)/;
if($1) {
$user = lc $1;
}
}elsif(/^Subject: (.*)$/) {
chomp;
$subj = $1;
$subj =~ s/\s//g;
}
}
syslog("cmd = $cmd");
if($cmd eq "subscribe") {
if(user_exist($user)) {
syslog("$user subscribed");
my $body = q(Hey guy, you have already subscribed!);
sendmail($user, "Subscribe failure", $body);
}else {
my $sid = gen_sid();
open(FD, "> $cfg{'listdir'}/$list/queue/$user") or
syslog("$!") and die "Can't write to $user, $!\n";
printf FD "%s\:%s\n", time, $sid;
close FD;
syslog("confirm $user");
my $body = "Hey guy, reply to me with the code $sid \n"
."in the subject section\n";
$list =~ m/([^:]+)\@(.*)/;
my $from = "$1-confirm\@$2";
sendmail($user, "Confirm subscribe", $body, $from);
}
}elsif($cmd eq "confirm") {
if(not user_exist($user)) {
syslog("$user not exist");
if(valid_sid($user, $subj)) {
syslog("added $user");
add_user($user);
my $body = "Welcome to $list :-)\n";
sendmail($user, "Added to the list", $body);
}else {
syslog("fail to confirm $user");
my $body = "Hey guy, your confirm fail, please try again\n";
sendmail($user, "Confirm failure", $body);
}
}else {
my $body = "Hey guy, you step into a wrong situation!\n";
sendmail($user, "Wrong action", $body);
}
}elsif($cmd eq "unsubscribe") {
if(user_exist($user)) {
syslog("$user removed");
del_user($user);
my $body = "Hey guy, you have been removed from the $list\n";
sendmail($user, "Goodbye - from $list", $body);
}else {
my $body = "Hey guy, you step into a wrong situation!\n";
sendmail($user, "Wrong action", $body);
}
}else {
print STDERR "m3 error cmd!\n";
exit(13);
}
exit(0);
## funcs to handle mail list
sub sendmail {
my($to, $subj, $body, $from) = @_;
if(not defined $from) {
$from = "m3\@$cfg{'hostname'}";
}
open(CMD, "| /usr/sbin/sendmail -oi -t -f \"$from\" $to") or
die "Can't exec /usr/sbin/sendmail, $!\n";
print CMD <<EOF
Return-Path: $from
From: $from
To: $to
Subject: $subj
$body
EOF
;
close CMD;
}
sub user_exist {
my $user = shift;
if (! -r "$cfg{'listdir'}/$list/users.txt") {
return 0;
}
open(FD, "< $cfg{'listdir'}/$list/users.txt") or die "Can't open $list, $!\n";
while(<FD>) {
chomp;
if(/^$user$/i) {
return 1;
}
}
close FD;
0;
}
# gen_sid - to generate unique Session id
sub gen_sid {
my ($sid, $len) = ("", $_[0] ? $_[0]-1 : 23);
srand(time());
foreach(0...$len) {
$sid .= $KEY_MAP[int rand(61)]; # total of $#KEY_MAP -1
}
$sid;
}
sub valid_sid {
my ($user, $sid) = @_;
open(FD, "< $cfg{'listdir'}/$list/queue/$user") or
syslog("can't open $user, $!") and die "Can't open $user, $!\n";
$_ = <FD>;
chomp;
($_) = m/[^:]+:(.*)/;
if($sid eq $_) {
syslog("auth ok for $user");
return 1;
}
close FD;
return 0;
}
sub add_user {
my ($user) = @_;
unlink "$cfg{'listdir'}/$list/queue/$user"; # clean up user cookie/queue
open(FD, ">> $cfg{'listdir'}/$list/users.txt") or
die "Can't append to users.txt for $list, $!\n";
print FD $user, "\n";
close FD;
}
sub del_user {
my ($user) = @_;
my $buf = undef;
open(FD, "< $cfg{'listdir'}/$list/users.txt") or
die "Can't open users.txt for $list, $!\n";
while(<FD>) {
chomp;
if(!/^$user$/) {
$buf.="$_\n";
}
}
close FD;
open(FD, "> $cfg{'listdir'}/$list/users.txt") or
die "Can't write to users.txt for $list, $!\n";
print FD $buf;
close FD;
}
sub syslog {
my ($msg) = @_;
chomp $msg;
printf $SLOG "%s $msg\n", time;
}
Posted by hzqbbc at 03:13 PM | Comments (0)
June 03, 2005
Perl Socket 编程样例（2）
前两天介绍了使用Socket及IO::Socket 来进行TCP client/server的编程基本套路和代码，现在再介绍使用Socket及IO::Socket模块来进行Unix domain Socket的client/server开发。
Unix Domain Socket（简称unix socket）和TCP/UDP等INET类型socket相比起来有几个优点：- 安全性高，unix socket只在单机环境中使用，不支持机器之间通信
- 效率高，执行时的速度约是TCP的两倍，多用于操作系统内部通信（IPC）
- 支持SOCK_DGRAM，但和UDP不同，前后消息是严格有序的
因此使用Unix socket来设计单机的IPC应用是首选。非常实用。大量的Unix应用软件都使用unix socket来进行程序间通信。
Unix Domain Socket客户端, Socket模块
简介：使用Unix domain socket的客户端。
#!/usr/bin/perl -w
use strict;
use Socket;
use IO::Handle;
my $path = $ARGV[0] || '/tmp/daytime.sock';
socket(my $sock, PF_UNIX, SOCK_STREAM, 0);
my $sun = sockaddr_un($path);
connect($sock, $sun) or die "Connect: $!\n";
$sock->autoflush(1);
my $buf = <$sock>;
my $bs = length($buf);
print "Received $bs bytes, content $buf\n";
close $sock;
Unix Domain Socket 服务端, Socket模块
简介：使用Unix domain socket实现的daytime服务器。
#!/usr/bin/perl -w
# tcp_socket_dt_srv.pl
use strict;
use Socket;
use IO::Handle;
use POSIX qw(WNOHANG);
my $path = $ARGV[0] || '/tmp/daytime.sock';
$SIG{'CHLD'} = sub {
while((my $pid = waitpid(-1, WNOHANG)) >0) {
print "Reaped child $pid\n";
}
};
socket(SOCK, PF_UNIX, SOCK_STREAM, 0)
or die "socket() failed: $!";
setsockopt(SOCK,SOL_SOCKET,SO_REUSEADDR,1)
or die "Can't set SO_REUSADDR: $!" ;
unlink $path if -r $path;
bind(SOCK,sockaddr_un($path)) or die "bind() failed: $!";
listen(SOCK,SOMAXCONN) or die "listen() failed: $!";
warn "Starting server on path $path...\n";
while (1) {
next unless my $sockname = accept(SESSION,SOCK);
defined (my $pid=fork) or die "Can't fork: $!\n";
if($pid==0) {
SESSION->autoflush(1);
print SESSION (my $s = localtime);
close SESSION;
exit 0;
}else {
print "Forking child $pid\n";
}
}
close SOCK;
...to be continued
Posted by hzqbbc at 09:00 AM | Comments (1)
June 01, 2005
Perl Socket 编程样例（1）
Perl的networking 功能非常强大，基本上用c/c++能做的事perl都能做，而且做得更轻松方便，甚至可以只用10来行代码就完成了c/c++要几十上百甚至几百行才能完成得好的工作。
在networking方面，最基础的是BSD socket编程，但往往perl入门时在这个方面，最头疼的无疑是如何开始，如何Step by step。最好的药方就是Example，一段完整的可以运行（working）的代码，通过实践来感受远比看枯燥的manual来得深刻。
以下给出几段使用Socket及IO::Socket编写的Server/client，他们能实现最简单但是却最基本的任务，包括一个forking/accept的模型。可以直接复制这些代码，然后小加修改即可开发一些小型的tcp/udp应用了。
TCP 客户端, Socket 模块
简介：实现从服务器端读取一行信息然后返回
#!/usr/bin/perl -w
# tcp_socket_cli.pl
use strict;
use Socket;
my $addr = $ARGV[0] || '127.0.0.1';
my $port = $ARGV[1] || '3000';
my $dest = sockaddr_in($port, inet_aton($addr));
my $buf = undef;
socket(SOCK,PF_INET,SOCK_STREAM,6) or die "Can't create socket: $!";
connect(SOCK,$dest) or die "Can't connect: $!";
my $bs = sysread(SOCK, $buf, 2048); # try to read 2048
print "Received $bs bytes, content $buf\n"; # actually get $bs bytes
close SOCK;
执行结果：
perl tcp_socket_cli.pl localhost 25 Received 41 bytes, content 220 ESMTP Postfix - ExtMail 0.12-hzqbbc
TCP 服务端 Socket模块, forking/accept模型
简介：一个多进程的TCP 服务器，sample中实现了daytime的功能
#!/usr/bin/perl -w
# tcp_socket_dt_srv.pl
use strict;
use Socket;
use IO::Handle;
use POSIX qw(WNOHANG);
my $port = $ARGV[0] || '3000';
my $proto = getprotobyname('tcp');
$SIG{'CHLD'} = sub {
while((my $pid = waitpid(-1, WNOHANG)) >0) {
print "Reaped child $pid\n";
}
};
socket(SOCK, AF_INET, SOCK_STREAM, getprotobyname('tcp'))
or die "socket() failed: $!";
setsockopt(SOCK,SOL_SOCKET,SO_REUSEADDR,1)
or die "Can't set SO_REUSADDR: $!" ;
my $my_addr = sockaddr_in($port,INADDR_ANY);
bind(SOCK,$my_addr) or die "bind() failed: $!";
listen(SOCK,SOMAXCONN) or die "listen() failed: $!";
warn "Starting server on port $port...\n";
while (1) {
next unless my $remote_addr = accept(SESSION,SOCK);
defined(my $pid=fork) or die "Can't fork: $!\n";
if($pid==0) {
my ($port,$hisaddr) = sockaddr_in($remote_addr);
warn "Connection from [",inet_ntoa($hisaddr),",$port]\n";
SESSION->autoflush(1);
print SESSION (my $s = localtime);
warn "Connection from [",inet_ntoa($hisaddr),",$port] finished\n";
close SESSION;
exit 0;
}else {
print "Forking child $pid\n";
}
}
close SOCK;
利用上述tcp_socket_cli.pl访问该server的执行结果：
[hzqbbc@local misc]$ perl tcp_socket_dt_srv.pl Starting server on port 3000... Connection from [127.0.0.1,32888] Connection from [127.0.0.1,32888] finished Reaped child 13927 Forking child 13927
TCP 客户端 ,IO::Sockiet模块
简介：同样为客户端，不过使用的是IO::Socket 面向对象模块
#!/usr/bin/perl -w
# tcp_iosocket_cli.pl
use strict;
use IO::Socket;
my $addr = $ARGV[0] || '127.0.0.1';
my $port = $ARGV[1] || '3000';
my $buf = undef;
my $sock = IO::Socket::INET->new(
PeerAddr => $addr,
PeerPort => $port,
Proto => 'tcp')
or die "Can't connect: $!\n";
$buf = <$sock>;
my $bs = length($buf);
print "Received $bs bytes, content $buf\n"; # actually get $bs bytes
close $sock;
TCP 服务端, IO::Socket模块, forking/accept模型
简介：同样的一个daytime 服务器，使用IO::Socket重写。
#!/usr/bin/perl
# tcp_iosocket_dt_srv.pl
use strict;
use IO::Socket;
use POSIX qw(WNOHANG);
$SIG = sub {
while((my $pid = waitpid(-1, WNOHANG)) >0) {
print "Reaped child $pid\n";
}
};
my $port = $ARGV[0] || '3000';
my $sock = IO::Socket::INET->new( Listen => 20,
LocalPort => $port,
Timeout => 60*1,
Reuse => 1)
or die "Can't create listening socket: $!\n";
warn "Starting server on port $port...\n";
while (1) {
next unless my $session = $sock->accept;
defined (my $pid = fork) or die "Can't fork: $!\n";
if($pid == 0) {
my $peer = gethostbyaddr($session->peeraddr,AF_INET) || $session->peerhost;
my $port = $session->peerport;
warn "Connection from [$peer,$port]\n";
$session->autoflush(1);
print $session (my $s = localtime), "\n";
warn "Connection from [$peer,$port] finished\n";
close $session;
exit 0;
}else {
print "Forking child $pid\n";
}
}
close $sock;
...to be continue...
Posted by hzqbbc at 09:03 AM | Comments (0)
May 27, 2005
perl 性能优化
Perl是强大的语言，是强大的工具，也是一道非常有味道的菜:-) 利用很多perl 的特性,可以实现一些非常有趣而实用的功能。
利用Perl开发一些服务应用时，有时会遇到性能或资源占用的问题，如何解决呢？以下是自己过去开发实践的一些经验，几个主要的技巧分别是：
- 巧用require装载模块
- 使用系统函数及XS化模块
- 自写低开销模块
- 优化正则表达式
- 善用BSD socket
巧用require装载模块
为避免程序一启动就加载大量模块，降低启动速度，可以在必要的时候再装载模块，这时候就是require大派用场的时候了。如：
#!/usr/bin/perl -w
use pre_load_module;
# Initialize some thing
init_args();
# if $use_this_module is true, load the Module
if($use_this_module) {
require Module;
}
上述代码中，如果变量$use_this_module设置了，那么才加载Module，如果没设置则不需要加载，实现了：use on demand的功能。在CGI应用程序中，这相当有用，如果每次请求（fork）都加载大量无用模块的话，响应速度会有所降低，而在特定场合才加载一些模块将加块启动、解析的速度。
再看一个例子：
#!/usr/bin/perl
my $pid = fork or die "can't fork:$!\n";
if($pid) {
print "i'm father\n";
sleep;
}else {
print "i'm child\n":
require IO::Socket;
sleep;
}
上述代码中，如果在程序一开始就用use 来载入IO::Socket模块，那么子/父进程都加载了该模块，通过top命令发现子父进程大小都是3.07MB；如果只在子进程里加载，则只在子进程里有效，内存的消耗将降低，top命令发现子进程3.04MB，父进程变为1.4MB。
使用系统函数及XS化模块
Perl内建的系统函数及用c编写的perl XS扩展模块的速度和效率都比纯perl的实现要好得多。在性能要求较高的场合（如开发Application Server，Network Server等），可以考虑使用这些内建函数或XS化模块。如Socket就比IO::Socket的内存消耗要低，XS编写的Data::Dumper就比纯Perl的Data::Dumper要快4-5倍。
此外，一些简单的任务并没必要使用Perl 模块，如获得主机IP地址就大可不必载入庞大的Net::DNS而只是使用gethostbyname()系统函数即可。
以下是一些常用的替代方案以获得更快的速度，更好的效率：自写低开销模块
通常我们使用一些Perl模块时，只使用了其中很小一部分的功能，可是却不得不载入整个模块，甚至要载入其他不相关的模块。因此往往使整个程序非常臃肿庞大。著名的web管理软件webmin的miniserv（一个简化的http服务端)功能强大，还支持SSL，但资源占用却出奇的少，只有大约5.6MB的大小！这是为什么呢？因为miniserver只使用了2个Perl 系统模块（Socket及POSIX），没有载入其他的模块。一些本需要其他perl 模块的功能，均由web-lib.pl等用系统函数编写代替。
例如以下是一个获得A记录的高速函数get_mx()，它不依赖任何模块，速度非常快。
sub get_mx {
my @info = gethostbyname shift;
my @addr = splice(@info, 4);
my @rt;
foreach(@addr) {
push @rt, join('.', unpack('C4', $_));
}
\@rt;
}
另一个例子，对于标准的IO::Handle对象，可以使用$obj->autoflush(1);来设置缓冲的特性，我们通过使用系统函数select()来获得同样的能力，而无需要载入IO::Handle，代码如下：
sub autoflush {
my $io = $_[0];
select((select($io), $|=1)[0]);
}
使用方法很简单，例如要对IO::Socket::INET类型的$sock设置为立即冲刷，则autoflush($sock)即可。
...to be continue...
Posted by hzqbbc at 05:30 PM | Comments (0)
May 06, 2005
如何捕捉CGI程序exception
用perl写cgi程序的时候，如果出现了问题，大多数都必须查看Web server的日志才能知道程序哪里出了错误，页面一般只返回500服务器错误，不能立刻获得错误的原因。
使用php的程序员就没有这个烦恼，因为php默认会将错误都打印到页面上。CGI程序里如何才能做到这一点呢？
CGI::Carp这个模块支持这个功能，以下是例子：
use CGI::Carp qw(fatalsToBrowser);
die "Bad error here";
详细请参阅CGI::Crap的在线手册
那如果是自己写的简单CGI程序，不使用CGI.pm怎么办？以下是简单的方法......
原理简述
Perl 提供了%SIG 这个特殊的HASH，通过定义信号响应函数，可以捕捉die及一些warning的信息，并将这些信息打印到web页上。但为了尽可能早的加载这些代码，最好将信号捕捉代码放到BEGIN块中，这样就能保证程序一执行就先执行异常捕捉这段代码了。
BEGIN {
# fatal handler setting.
$SIG{__DIE__} = $SIG{__WARN__} = \&some_func;
}
代码例子
以下是一个简单的例程，定义了一个叫handler_fatal处理函数来处理意外错误信息。
#!/usr/bin/perl -w
use strict
BEGIN {
# fatal handler setting.
$SIG{__DIE__} = $SIG{__WARN__} = \&handler_fatal;
}
# some perl code goes here
......
sub handler_fatal {
print "Content-type: text/html\n\n";
print "@_";
}
上面这段perl程序中，如果调用一个名称为abc();的子例程，浏览器将看到如下的错误信息：
Undefined subroutine &main::abc called at /home/hzqbbc/cgi-bin/fatal.cgi line 8.
通过这个方法就可以很简便的进行程序调试了。Extmail中的CGI.pm就是使用类似的方法，可以捕捉die(), warn() 等函数产生的错误及系统的错误提示。
Posted by hzqbbc at 09:00 AM | Comments (2)