Perl模块使用 => 简短例子代码集合！

Perl模块使用 => 简短例子代码集合！
http://www.chinaunix.net/ 作者:deathcult 发表于：2003-06-06 17:32:55

如果你有模块使用范例(请尽量简洁)，请帖新贴，
或坛内邮件(主题:perl模块使用范例)给我，由我测试
整理以后，在此发布。
希望多多支持！

真心希望朋友们能在chinaunix受益。大家共同进步！
谢谢！ ：）

[b:4017a0b519]已有模块：[/b:4017a0b519]
说明：
以下例子代码的测试是在FreeBSD & Solaris下进行的，Perl版本为5.005_03。
[b:4017a0b519]
(1) LWP::Simple, get()
(2) Time::HiRes, gettimeofday(), usleep()
(3) Net::FTP
(4) Expect
(5) XML::Simple, XMLin()
(6) Data::Dumper, Dumper()
(7) IO::Socket
(8) Date::Manip, DateCalc(), UnixDate()
(9) Date::Manip, Date_Cmp()
(10) File::Find, find()
(11) ExtUtils::Installed, new(), modules(), version()
(12) DBI, connect(), prepare(), execute(), fetchrow_array()
(13) Getopt::Std
(14) Proc::ProcessTable
(15) Shell
(16) Time::HiRes, sleep(), time()
(17) HTML::LinkExtor, links(), parse_file()
(18) Net::Telnet, open(), print(), getline()
(19) Compress::Zlib, gzopen(), gzreadline(), gzclose()
(20) Net::POP3, login(), list(), get()
(21) Term::ANSIColor
(22) Date::Calc Calendar(), Today()
(23) Term::Cap, Tgetend(), Tgoto, Tputs()
(24) HTTPD::Log::Filter
(25) Net::LDAP
(26) Net::SMTP mail(), to(), data(), datasend(), auth()
(27) MIME::Base64, encode_base64(), decode_base64()
(28) Net::IMAP::Simple, login(), mailboxes(), select(), get()...
(29) Bio::DB::GenBank, Bio::SeqIO
(30) Spreadsheet::ParseExcel
(31) Text::CSV_XS, parse(), fields(), error_input()
[/b:4017a0b519]
说明：
以下例子代码的测试是在RH Linux7.2下进行的，Perl版本为5.6.0。
[b:4017a0b519]
(32) Benchmark
(33) HTTP::Daemon, accept(), get_request()...
(34) Array::Compare, compare(), full_compare()...
(35) Algorithm::Diff, diff()
(36) List::Util, max(), min(), sum(), maxstr(), minstr()...
(37) HTML::Parser
(38) Mail::Sender
[/b:4017a0b519]

【发表回复】【查看论坛原帖】【添加到收藏夹】【关闭】

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-06 17:34:10
[b:1cff340126](1) LWP::Simple, get()[/b:1cff340126]

[code:1:1cff340126]
#!/usr/bin/perl -w
use strict;
use LWP::Simple qw(get);

my $url = shift "http://www.chinaunix.net/";
my $content = get($url);

print $content;

exit 0;
[/code:1:1cff340126]

最简单方便的get网页的方法。

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-06 17:35:56
[b:052512c920](2) Time::HiRes, gettimeofday(), usleep()[/b:052512c920]
[code:1:052512c920]
#!/usr/bin/perl -w
use strict;
use Time::HiRes qw(gettimeofday usleep);

my ($start_sec, $start_usec, $end_sec, $end_usec, $time_used);
my $micro_sec = 100000;
($start_sec, $start_usec) = gettimeofday;

foreach(1..20)
{
print `date +\%H:\%M:\%S`;
usleep($micro_sec);
}

($end_sec, $end_usec) = gettimeofday;
$time_used = ($end_sec - $start_sec) + ($end_usec - $start_usec)/1000000;

printf("time used : %.3fsec\n", $time_used);
exit 0;
[/code:1:052512c920]

提供微秒级时间处理。

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-06 17:37:00
[b:ef0e194476](3) Net::FTP[/b:ef0e194476]
[code:1:ef0e194476]
#!/usr/bin/perl
use strict;
use Net::FTP;

my $user = "anonymous";
my $passwd = "chinaunix@";
my $host = "ftp://ftp.freebsd.org/";

my $ftp = Net::FTP->new("$host", Debug => 0)
or die "Can't connect to $host: $@\n";

$ftp->login("$user","$passwd")
or die "Can't login\n", $ftp->message;

$ftp->cwd("/pub/FreeBSD/doc/")
or die "Can't change dir\n", $ftp->message;

$ftp->get("README")
or die "get failed\n", $ftp->message;

$ftp->quit;
exit 0;
[/code:1:ef0e194476]

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-06 17:37:27
[b:0cf83fce47](4) Expect[/b:0cf83fce47]
[code:1:0cf83fce47]
#!/usr/bin/perl
use strict;
use Expect;

my $timeout = 2;
my $delay = 1;
my $cmd = "ssh";
my @params = qw/202.108.xx.xx -lusername -p22/;
my $pass = "passwd";

my $exp = Expect->spawn($cmd, @params) or die "Can't spawn $cmd\n";
$exp->expect($timeout, -re=>'[Pp]assword:');
$exp->send_slow($delay, "$pass\r\n");

$exp->interact();
$exp->hard_close();

exit 0;
[/code:1:0cf83fce47]

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-06 17:37:51
[b:3731b6956f](5) XML::Simple, XMLin()[/b:3731b6956f]
[code:1:3731b6956f]
#!/usr/bin/perl -w
use strict;
use XML::Simple;

my $text = <<xml;
<?xml version="1.0"?>
<web-app>
<servlet>
<servlet-name>php</servlet-name>
<servlet-class>net.php.servlet</servlet-class>
</servlet>
<servlet-mapping>
<servlet-name>php</servlet-name>
<url-pattern>*.php</url-pattern>
</servlet-mapping>
</web-app>
xml

my $x = XMLin($text);
foreach my $tag(keys %$x)
{
my %h = %{$$x{$tag}};
foreach(keys %h)
{
print "$tag => ";
print "$_ => $h{$_}\n";
}
}
exit 0;
[/code:1:3731b6956f]

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-06 17:38:15
[b:c07638d0d4](6) Data::Dumper, Dumper()[/b:c07638d0d4]
[code:1:c07638d0d4]
#!/usr/bin/perl -w
use strict;
use Data::Dumper;

print Dumper(\@INC);
print Dumper(\%ENV);
exit 0;
[/code:1:c07638d0d4]

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-06 17:38:39
[b:77c5553356](7) IO::Socket[/b:77c5553356]
[code:1:77c5553356]
#!/usr/bin/perl -w
use strict;
use IO::Socket;

my $host = "http://www.chinaunix.net/";
my $port = "80";
my $http_head = "GET / HTTP/1.0\nHost: $host:$port\n\n";
my $sock = IO::Socket::INET->new("$host:$port")
or die "Socket() error, Reason : $! \n";

print $sock $http_head;
print <$sock>;

exit 0;
[/code:1:77c5553356]

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-06 18:34:26
[b:8cb441d214](8) Date::Manip, DateCalc(), UnixDate()[/b:8cb441d214]
[code:1:8cb441d214]
#!/usr/bin/perl
use strict;
use Date::Manip;

my $date=&DateCalc("today","-1 days", 0);#yesterday
my $date=&UnixDate($date, "%Y-%m-%d %T");

print "$date\n";
exit 0;
[/code:1:8cb441d214]

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-06 18:42:26
[b:6a9799e29a](9) Date::Manip, Date_Cmp()[/b:6a9799e29a]
#用于时间日期的比较
[code:1:6a9799e29a]
#!/usr/bin/perl
use strict;
use Date::Manip;
my $date1 = "Fri Jun 6 18:31:42 GMT 2003";
my $date2 = "2003/05/06";
my $flag=&Date_Cmp($date1,$date2);

if($flag<0)
{
print "date1 is earlier!\n";
}
elsif($flag==0)
{
print "the two dates are identical!\n";
}
else
{
print "date2 is earlier!\n";
}
exit 0;
[/code:1:6a9799e29a]

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-06 18:53:20
[b:58ec399f21](10) File::Find, find()[/b:58ec399f21]
[code:1:58ec399f21]
#!/usr/bin/perl -w
use strict;
use File::Find;

my $file = "access.log";
my $path = "/";

find(\&process, $path);

sub process{ print $File::Find::dir, "$_\n" if(/$file/); }

exit 0;
[/code:1:58ec399f21]

#用于在unix文件树结构中查找对象。

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-09 21:55:40
[b:2c4c797d63](11) ExtUtils::Installed, new(), modules(), version()[/b:2c4c797d63]

查看已经安装的模块的相应信息。

[code:1:2c4c797d63]
#!/usr/bin/perl
use strict;
use ExtUtils::Installed;

my $inst= ExtUtils::Installed->new();
my @modules = $inst->modules();

foreach(@modules)
{
my $ver = $inst->version($_) "???";
printf("%-12s -- %s\n", $_, $ver);
}
exit 0;
[/code:1:2c4c797d63]

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-09 21:56:35
[b:18d9c37f32](12) DBI, connect(), prepare(), execute(), fetchrow_array()[/b:18d9c37f32]
[code:1:18d9c37f32]
#!/usr/bin/perl
use strict;
use DBI;

my $dbh = DBI->connect("dbi:mysql:dbname", 'user','passwd', '')
or die "can't connect!\n";
my $sql = qq/show variables/;
my $sth = $dbh->prepare($sql);
$sth->execute();

while(my @array=$sth->fetchrow_array())
{
printf("%-35s", $_) foreach(@array);
print "\n";
}
$dbh -> disconnect();
exit 0;
[/code:1:18d9c37f32]

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-09 21:57:22
[b:8dc1acce8b](13) Getopt::Std[/b:8dc1acce8b]

命令行参数解析。

[code:1:8dc1acce8b]
#!/usr/bin/perl
use strict;
use Getopt::Std;

my %opts;
getopts("c:hv", \%opts);

foreach(keys %opts)
{
/c/ && print "welcome to ", $opts{$_} "ChinaUnix", "!\n";
/h/ && print "Usage : $0 -[hv] -[c msg] \n";
/v/ && print "This is demo, version 0.001.001 built for $^O\n";
}
exit 0;
[/code:1:8dc1acce8b]

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-09 21:58:01
[b:77d6b3fce2](14) Proc::ProcessTable[/b:77d6b3fce2]
#直接访问Unix进程表，类似ps command。
[code:1:77d6b3fce2]
#!/usr/bin/perl
use strict;
use Proc::ProcessTable;

my $pt = new Proc::ProcessTable;

foreach(reverse sort @{$pt->table})
{
print $_->pid, " => ";
print $_->cmndline, "\n";
}
exit 0;
[/code:1:77d6b3fce2]

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-09 21:58:36
[b:78ebfbee8b](15) Shell[/b:78ebfbee8b]
[code:1:78ebfbee8b]
#!/usr/bin/perl
use strict;
use Shell;

print "now is : ", date();
print "current time is : ", date("+%T");

my @dirs = ls("-laF");
foreach(@dirs)
{
print if(/\/$/);#print directory
}
exit 0;
[/code:1:78ebfbee8b]

Shell命令直接做为函数，在Perl中调用。

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-10 13:59:31
Another use of Time::HiRes Module.

[b:9cf174f8a9](16) Time::HiRes, sleep(), time()[/b:9cf174f8a9]
[code:1:9cf174f8a9]
#!/usr/bin/perl
use strict;
use Time::HiRes qw(sleep time);

$ = 1;
my $before = time;
for my $i (1..100)
{
print "$i\n";
sleep(0.01);
}
printf("time used : %.5f seconds\n", time - $before);
exit 0;
[/code:1:9cf174f8a9]

use Time::HiRes后，此模块提供sleep(), alarm(), time()的增强版以
取代perl内置的相应函数。
其中sleep()和alarm()的参数可以是小数。比如sleep(0.1)表示休眠0.1秒，
time()可以返回浮点数。

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-10 16:06:11
[b:e4b55642c1](17) HTML::LinkExtor, links(), parse_file()[/b:e4b55642c1]
[code:1:e4b55642c1]
#!/usr/bin/perl
use strict;
use HTML::LinkExtor;

my $p = new HTML::LinkExtor;
$p->parse_file(*DATA);

foreach my $links ($p->links())
{
map {print "$_ "} @{$links};
print "\n";
}
exit 0;

__DATA__

<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1 Strict//EN"
"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns=" http://www.w3.org/1999/xhtml" xml:lang="en-US">
<head>
<meta http-equiv="Content-Type" content="text/html"/>
<title>CPAN</title>
<!-- Copyright Jarkko Hietaniemi <[e-mail]> 1998-2002
All Rights Reserved.
The CPAN Logo provided by J.C. Thorpe.
You may distribute this document either under the Artistic License
(comes with Perl) or the GNU Public License, whichever suits you.

You are not allowed to remove or alter these comments. -->
<!-- $Id: cpan-index.html,v 1.7 2003/02/17 10:23:46 jhi Exp $ -->
<link rev="made" href="http://www.blogger.com/'mailto:[e-mail]>
<style type="text/css">
<!--

body{
color:black;
background:white;
margin-left:2%;
margin-right:2%;
}

h1{
text-align:center;
}

img {
vertical-align: 50%;
border: 0;
}

.left{
text-align:left;
float:none;
}

.center{
text-align:center;
float:none;
}

.right{
text-align:right;
float:none;
}

-->
</style>
</head>
<body>

<table width="100%">
<tr>
<td rowspan="2">
<div class="left">
<img src="misc/jpg/cpan.jpg"
alt="[CPAN Logo]" height="121" width="250"/>
</div>
</td>
<td>
<div class="right">
<h1><a id="top">Comprehensive Perl Archive Network</a></h1>
</div>
</td>
</tr>
<tr>
<td>
<div class="center">
2003-06-10 online since 1995-10-26<br/>1662 MB 246 mirrors<br/>2903 authors 4767 modules
</div>
</td>
</tr>
<tr>
<td colspan="2">
<p class="left">
Welcome to CPAN! Here you will find All Things Perl.
</p>
</td>
<td>
</td>
</tr>
</table>

<hr/>

<table width="100%">

<tr>

<td>

<h1>Browsing</h1>
<ul>
<li><a href="modules/index.html">Perl modules</a></li>
<li><a href="scripts/index.html">Perl scripts</a></li>
<li><a href="ports/index.html">Perl binary distributions ("ports")</a></li>
<li><a href="src/README.html">Perl source code</a></li>
<li><a href="RECENT.html">Perl recent arrivals</a></li>
<li><a href="http://www.blogger.com/'http://search.cpan.org/recent> Perl modules</li>
<li><a href="SITES.html">CPAN sites</a> list</li>
<li><a href="http://www.blogger.com/'http://mirrors.cpan.org/sites</a> map</li>
</ul>

</td>

<td>

<h1>Searching</h1>

<ul>
<li><a href="http://www.blogger.com/'http://kobesearch.cpan.org/ core and CPAN modules documentation </a> (Randy Kobes)</li>
<li><a href=" http://www.blogger.com/'http://www.perldoc.com/ core documentation</a> (Carlos Ramirez)</li>
<li><a href=" http://search.cpan.org/">CPAN modules, distributions, and authors</a> (search.cpan.org)</li>
<li><a href=" http://wait.cpan.org/">CPAN modules documentation</a> (Ulrich Pfeifer)</li>
</ul>

<h1>FAQ etc</h1>

<ul>
<li><a href="misc/cpan-faq.html">CPAN Frequently Asked Questions</a></li>
<li><a href="http://www.blogger.com/'http://lists.cpan.org/Mailing Lists</a></li>
<li><a href="http://www.blogger.com/'http://bookmarks.cpan.org/ Bookmarks</a></li>
</ul>

<p><small>
Yours Eclectically, The Self-Appointed Master Librarian (OOK!) of the CPAN<br/>
<i>Jarkko Hietaniemi</i>
<a href="http://www.blogger.com/'mailto:[e-mail]>
<a href="disclaimer.html">[Disclaimer]</a>
</small>
</p>

</td>

</tr>

</table>

<hr/>

<table width="100%">
<tr>

<td>
<div class="left">
<a href="http://validator.w3.org/check?uri=http%3A%2F%2Fwww.cpan.org%2Findex.html">
<img src="misc/gif/valid-xhtml10.gif" alt="Valid XHTML 1.0!" height="31" width="88"/></a>
<a href=" http://jigsaw.w3.org/css-validator/validator?uri=http%3A%2F%2Fwww.cpan.org%2Findex.html">
<img src="misc/gif/vcss.gif" alt="[Valid CSS]" height="31" width="88"/></a>
</div>
</td>
<td>
<div class="right">

<table width="100%">

<tr>
<td class="right">
<small>
CPAN master site hosted by
</small>
</td>
</tr>
<tr>
<td class="right">
<a href=" http://www.blogger.com/'http://www.csc.fi/suomi/funet/verkko.html.en/ src="misc/gif/funet.gif" alt="FUNET" height="25" width="88"/></a>
</td>
</tr>
</table>

</div>
</td>

</tr>
</table>

</body>
</html>
[/code:1:e4b55642c1]

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-11 11:47:34
[b:30dc396132](18) Net::Telnet, open(), print(), getline()[/b:30dc396132]
[code:1:30dc396132]
#!/usr/bin/perl
use strict;
use Net::Telnet;

my $p = Net::Telnet->new();
my $h = shift "http://www.chinaunix.net/";

$p->open(Host => $h, Port => 80);
$p->print("GET /\n");
while(my $line = $p->getline())
{
print $line;
}
exit 0;
[/code:1:30dc396132]

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-11 14:21:45
[b:fdf25ecb64](19) Compress::Zlib, gzopen(), gzreadline(), gzclose()[/b:fdf25ecb64]
[code:1:fdf25ecb64]
#!/usr/bin/perl
use strict;
use Compress::Zlib;

my $gz = gzopen("a.gz", "rb");

while( $gz->gzreadline(my $line) > 0 )
{
chomp $line;
print "$line\n";
}

$gz->gzclose();
exit 0;
[/code:1:fdf25ecb64]

#直接使用shell的zmore, zless, zcat打开文件也不错，
但是如果gz文件很大，还是应该选择zlib。

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-13 15:33:20
[b:949cc5c4f4](20) Net::POP3, login(), list(), get()[/b:949cc5c4f4]
[code:1:949cc5c4f4]
#!/usr/bin/perl
use strict;
use Net::POP3;
use Data::Dumper;

my $user = "user";
my $pass = shift or die "Usage : $0 passwd\n";
my $host = "pop3.web.com";#pop3 address

my $p = Net::POP3->new($host) or die "Can't connect $host!\n";
$p->login($user, $pass) or die "user or passwd error!\n";
my $title = $p->list or die "No mail for $user\n";

foreach my $h(keys %$title)
{
my $msg = $p->get($h);
print @$msg;
}
$p->quit;
exit 0;
[/code:1:949cc5c4f4]

telnet pop3.web.com 110 也可以直接连到pop3 server上，然后通过
pop3命令与邮件服务器交互，
简单的命令有：
USER name
PASS string

STAT
LIST [n]
RETR msg
DELE msg
NOOP
RSET
QUIT
有兴趣的朋友可以试一试。
这样，也就可以利用Net::Telnet来做一个收信件的简单程序。

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-16 14:39:38
[b:5b55b3a0a4](21) Term::ANSIColor 例子一[/b:5b55b3a0a4]
[code:1:5b55b3a0a4]
#!/usr/bin/perl
use strict;
use Term::ANSIColor qw(:constants);

$Term::ANSIColor::AUTORESET = 1;

$ = 1;
my $str = "Welcome to chinaunix ^_^!\n";

for my $i(0..length($str)-1)
{
print BOLD RED substr($str, $i, 1);
select(undef, undef, undef, 0.3);
}
exit 0;
[/code:1:5b55b3a0a4]

查看ANSIColor.pm可以得知作者是利用ANSI转义序列，改变终端字符颜色的。
print "\e[34m\n";
即是改变前景色为blue;

shell命令为echo -e "\033[31m";#改变前景色为红色。
(freeBSD，Solaris下此命令测试OK)

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-16 14:57:12
[b:afcbe8a2d7](21) Term::ANSIColor 例子二[/b:afcbe8a2d7]
[code:1:afcbe8a2d7]
#!/usr/bin/perl
use strict;
use Term::ANSIColor qw(:constants);

$Term::ANSIColor::AUTORESET = 1;

$ = 1;

print "\e[20;40H";
my $str = "Welcome to chinaunix ^_^!\n";

print BOLD BLINK $str;
exit 0;
[/code:1:afcbe8a2d7]

转义序列echo -e "\033[20;40H";可以改变光标位置。
perl中就可以：print "\e[20;40H";

详细请搜索精华。还有perldoc Term::ANSIColor 。

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-16 17:13:23
[b:efafcd6b60](22) Date::Calc Calendar(), Today()[/b:efafcd6b60]
[code:1:efafcd6b60]
#!/usr/bin/perl
use strict;
use Date::Calc qw(Calendar Today);

my $year = "2003";
my $month = "6";
my $day;

my $cal = Calendar($year, $month);
(undef, undef, $day) = Today();

$cal =~ s/$day/\e[5m\e[31m$day\e[0m/;

print $cal;
exit 0;
[/code:1:efafcd6b60]

本例子打印出一个2003年6月份的日历，当天日期用红色的闪烁数字表示。

Date::Calc提供了时间日期计算的另一种方式（一种是Date::Manip），
大量简单方便的方法（函数）供使用者调用。

在例子中的年和月我是自己指定的，也可以
($year, $month, $day) = Today();

颜色和闪烁是用ANSI escape sequences。
详细说明尽在[color=red:efafcd6b60]ANSIColor.pm source[/color:efafcd6b60]和perldoc Term::ANSIColor里。
（perldoc Term::ANSIColor其实也在ANSIColor.pm source里） ：）

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-20 13:45:16
[b:abf4262fc5](23) Term::Cap, Tgetend(), Tgoto, Tputs()[/b:abf4262fc5]
[code:1:abf4262fc5]
#!/usr/bin/perl
use strict;
use Term::Cap;

$ = 1;
my $i = 1;
my $flag = 0;

my $tcap = Term::Cap->Tgetent({TERM => undef, OSPEED => 1});
$tcap->Tputs('cl', 1, *STDOUT);#clear screen

while($i)
{
if($i > 50 $flag == 1)
{
$i --;
$flag = 1;
$flag = 0 if($i == 1);
}
else
{
$i ++;
$flag = 0;
}

$tcap->Tgoto('cm', $i, 15, *STDOUT);#move cursor
print " welcome to chinaunix! ";
select(undef, undef, undef, 0.02);
}
exit 0;
[/code:1:abf4262fc5]

Term::Cap 终端控制模块。
代码效果：一个左右移动的字串 "welcome to chinaunix! " ：）

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-20 13:46:09
[b:9167f46313](24) HTTPD::Log::Filter[/b:9167f46313]
[code:1:9167f46313]
#!/usr/bin/perl
use strict;
use HTTPD::Log::Filter;

my $filter = HTTPD::Log::Filter->new(format => "CLF",
capture => ['request', 'host']);

foreach(`cat access_log`)
{
chomp;
unless( $filter->filter($_) )
{
print "[$_]\n";
next;
}
print $filter->request, "\n";
}
exit 0;
[/code:1:9167f46313]

如果我们工作中经常需要分析Apache日志，这个模块可以提供一些方便。
创建对象实例以后，用filter方法来过滤，没有正确匹配的行将返回false,
然后用相应的方法print出我们需要的数据。(host,request,date...等等方法，
由capture选项以参数引入)
可以用re方法打印出作者所使用的匹配模式：

[code:1:9167f46313]
use HTTPD::Log::Filter;
print HTTPD::Log::Filter->new(format=>"CLF",capture=>['request'])->re;
[/code:1:9167f46313]

详见perldoc HTTPD::Log::Filter. enjoy it

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-23 10:35:01
[b:7568f21ea8]提供者：Apile[/b:7568f21ea8]

[b:7568f21ea8](25) Net::LDAP[/b:7568f21ea8]
[code:1:7568f21ea8]
#!/usr/bin/perl
use Net::LDAP;

## get a object of ldap
$ldap = Net::LDAP->new("1.1.1.1", port =>"389", version => 3) or die "$@";
# object of Net::LDAP::Message
$mesg = $ldap->bind($_cer_id, password => $_cer_pw); # 查詢用的ID/PASSWD
if($mesg->is_error) {die $mesg->error;}
$mesg = $ldap->search(
base => "o=abc,c=tt", # 起始點
scope => "sub", # 範圍
filter => "(uid=apile)", # 條件
attrs => ["cn"], # 要取得的attribute
typesonly => 0 );

my $max_len = $mesg->count; ## get number of entry

#--取得中文姓名，可能不只一筆
for($i=0;$i<$max_len;$i++){
$entry = $mesg->entry($i);
$cname = $entry->get_value("cn"); # get chinese name
}

#--作密碼認證
$mesg = $ldap->bind($entry->dn, password => "abc", version => 3)
die "can't connect to ldap";
if($mesg->code) { print "verification is failed"}
else{ print "success"}
[/code:1:7568f21ea8]

LDAP version 3..可以用於查詢基本資料、驗證密碼之用..

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-26 17:37:28
[b:29ad8c33a1](26) Net::SMTP mail(), to(), data(), datasend(), auth() [/b:29ad8c33a1]
[code:1:29ad8c33a1]
#!/usr/bin/perl

use strict;
use Net::SMTP;

my $smtp = Net::SMTP->new('smtp.sohu.com', Timeout => 10, Debug => 0)
or die "new error\n";
#$smtp->auth("user", "passwd") or die "auth error\n";
$smtp->mail('some');
$smtp->to('[e-mail]');
$smtp->data("chinaunix,哈楼你好啊!\n:)");
$smtp->quit;

exit 0;

[/code:1:29ad8c33a1]

有的SMPT Server需要Authentication，那么就使用auth()方法进行验证。
Debug模式打开，可以看到详细的SMTP命令代码。也有助于我们排错。

--------------------------------------------------------------------------------
deathcult 回复于：2003-06-26 17:43:33
[b:60ac854086](27) MIME::Base64, encode_base64(), decode_base64() [/b:60ac854086]
[code:1:60ac854086]
#!/usr/bin/perl -w

use strict;
use MIME::Base64;

foreach(<DATA>)
{
print decode_base64($_);
}
exit 0;

__DATA__
xOO6w6Osu7bTrcC0tb1jaGluYXVuaXguY29tIFtwZXJsXbDmIQo=
1eLKx2Jhc2U2NLHgwuu1xMD919OjrNPJTUlNRTo6QmFzZTY0xKO/6cC0veLC66GjCg==
cGVybGRvYyBNSU1FOjpCYXNlNjQgZm9yIGRldGFpbHMsIGVuam95IGl0IDopCg==

[/code:1:60ac854086]

用来处理MIME/BASE64编码。

--------------------------------------------------------------------------------
deathcult 回复于：2003-07-07 18:54:45
[b:8a05a03bde](28) Net::IMAP::Simple, login(), mailboxes(), select(), get()...[/b:8a05a03bde]
[code:1:8a05a03bde]
#!/usr/bin/perl

use strict;
use Net::IMAP::Simple;

my $server = new Net::IMAP::Simple( 'imap.0451.com' );
$server->login( 'user_name', 'passwd');

#show the mailboxs
#map {print "$_\n";} $server->mailboxes();

#show mail's content
my $n = $server->select( 'inbox' ) or die "no this folder\n";
foreach my $msg ( 1..$n )
{
my $lines = $server->get( $msg );
print @$lines;
print "_________________ Press enter key to view another! ...... __________________\n";
read STDIN, my $key, 1;
}

exit 0;
[/code:1:8a05a03bde]

在取得中文的Folder时，会出现乱码的情况，
这个问题现在没有解决。英文的Folder则没问题。

IMAP协议，默认端口为143，可以用telnet登录。

telnet imap.xxx.com 143
2 login user pass
2 list "" *
2 select inbox
......

--------------------------------------------------------------------------------
deathcult 回复于：2003-08-01 10:44:38
[b:fd03fe9bbf]提供者：flora[/b:fd03fe9bbf]

[b:fd03fe9bbf](29) Bio::DB::GenBank, Bio::SeqIO[/b:fd03fe9bbf]

bioperl(http://bioperl.org/)模块使用--生物信息学中用的模块
功能：根据核酸的gi号自动从GenBank中提取FASTA格式的序列，可以多序列提取。
代码如下：

[code:1:fd03fe9bbf]
#!/usr/bin/perl -w

use Bio::DB::GenBank;
use Bio::SeqIO;
my $gb = new Bio::DB::GenBank;

my $seqout = new Bio::SeqIO(-fh => \*STDOUT, -format => 'fasta');

# if you want to get a bunch of sequences use the batch method
my $seqio = $gb->get_Stream_by_id([ qw(27501445 2981014)]);

while( defined ($seq = $seqio->next_seq )) {
$seqout->write_seq($seq);
}
[/code:1:fd03fe9bbf]

--------------------------------------------------------------------------------
deathcult 回复于：2003-08-01 12:25:14
[b:40fe86b30f]提供者：flora[/b:40fe86b30f]

[b:40fe86b30f]（30） Spreadsheet::ParseExcel[/b:40fe86b30f]
perl解析Excel文件的例子。

[code:1:40fe86b30f]
#!/usr/bin/perl -w

use strict;
use Spreadsheet::ParseExcel;
use Spreadsheet::ParseExcel::FmtUnicode; #gb support

my $oExcel = new Spreadsheet::ParseExcel;

die "You must provide a filename to $0 to be parsed as an Excel file" unless @ARGV;
my $code = $ARGV[1] "CP936"; #gb support
my $oFmtJ = Spreadsheet::ParseExcel::FmtUnicode->new(Unicode_Map => $code); #gb support
my $oBook = $oExcel->Parse($ARGV[0], $oFmtJ);
my($iR, $iC, $oWkS, $oWkC);
print "FILE :", $oBook->{File} , "\n";
print "COUNT :", $oBook->{SheetCount} , "\n";

print "AUTHOR:", $oBook->{Author} , "\n"
if defined $oBook->{Author};

for(my $iSheet=0; $iSheet < $oBook->{SheetCount} ; $iSheet++)
{
$oWkS = $oBook->{Worksheet}[$iSheet];
print "--------- SHEET:", $oWkS->{Name}, "\n";
for(my $iR = $oWkS->{MinRow} ;
defined $oWkS->{MaxRow} && $iR <= $oWkS->{MaxRow} ;
$iR++)
{
for(my $iC = $oWkS->{MinCol} ;
defined $oWkS->{MaxCol} && $iC <= $oWkS->{MaxCol} ;
$iC++)
{
$oWkC = $oWkS->{Cells}[$iR][$iC];
print "( $iR , $iC ) =>", $oWkC->Value, "\n" if($oWkC);
}
}
}
[/code:1:40fe86b30f]

--------------------------------------------------------------------------------
deathcult 回复于：2003-08-08 15:31:06
[b:a3ac59f8f5](31) Text::CSV_XS, parse(), fields(), error_input()[/b:a3ac59f8f5]

如果field里面也包含分隔符(比如"tom,jack,jeff","rose mike",O'neil,"kurt,korn")，那么我们解析起来确实有点麻烦，
Text::CSV_XS挺方便。

[code:1:a3ac59f8f5]
#!/usr/bin/perl

use strict;
use Text::CSV_XS;

my @columns;
my $csv = Text::CSV_XS->new({
'binary' => 1,
'quote_char' => '"',
'sep_char' => ','
});

foreach my $line(<DATA>)
{
chomp $line;
if($csv->parse($line))
{
@columns = $csv->fields();
}
else
{
print "[error line : ", $csv->error_input, "]\n";
}

map {printf("%-14s\t", $_)} @columns;
print "\n";
}
exit 0;

__DATA__
id,compact_sn,name,type,count,price
37,"ITO-2003-011","台式机,compaq","128M","290","1,2900"
35,I-BJ-2003-010,"显示器,硬盘,内存",'三星',480,"1,4800"
55,"C2003-104",笔记本,"Dell,Latitude,X200",13900,"1,13900"
[/code:1:a3ac59f8f5]

--------------------------------------------------------------------------------
deathcult 回复于：2003-08-15 18:34:44
[b:92ed062c8a]提供者：Apile[/b:92ed062c8a]

[b:92ed062c8a](32) Benchmark[/b:92ed062c8a]

[code:1:92ed062c8a]
#!/usr/bin/perl

use Benchmark;

timethese(100,
{
'local'=>q
{
for(1..10000)
{
local $a=$_;
$a *= 2;
}
},

'my'=>q
{
for(1..10000)
{
my $a=$_;
$a *= 2;
}
}
});
[/code:1:92ed062c8a]

可以拿來算某個algorithm耗費多少時間..
timethese(做幾次iteration,{
'Algorithm名稱'=>q{ 要計算時間的algorithm },
'Algorithm名稱'=>q{ 要計算時間的algorithm }
});

--------------------------------------------------------------------------------
deathcult 回复于：2003-08-15 19:42:08
[b:e10491980c](33) HTTP::Daemon, accept(), get_request(), send_file_response()[/b:e10491980c]

一个简单的，只能处理单一请求的Web服务器模型。
send_file_response()方法能把Client请求的文件传送过去。

[code:1:e10491980c]
#!/usr/bin/perl

use HTTP::Daemon;

$ = 1;
my $wwwroot = "/home/doc/";
my $d = HTTP::Daemon->new die;
print "Perl Web-Server is running at: ", $d->url, " ...\n";

while (my $c = $d->accept)
{
print $c "Welcome to Perl Web-Server<br>";

if(my $r = $c->get_request)
{
print "Received : ", $r->url->path, "\n";
$c->send_file_response($wwwroot.$r->url->path);
}

$c->close;
}
[/code:1:e10491980c]

--------------------------------------------------------------------------------
deathcult 回复于：2003-08-21 15:45:32
[b:d789d34a35](34) Array::Compare, compare(), full_compare()[/b:d789d34a35]

用于数组比较。
本例实现类似shell command - diff的功能。
如果我们要比较的不是文件，而是比如系统信息，远程文件列表，数据库内容变化等，这个模块会给我们提供方便灵活的操作。

[code:1:d789d34a35]
#!/usr/bin/perl

use Array::Compare;

$comp = Array::Compare->new(WhiteSpace => 1);
$cmd = "top -n1 head -4";
@a1 = `$cmd`;
@a2 = `$cmd`;

@result = $comp->full_compare(\@a1, \@a2);

foreach(@result)
{
print $_ + 1, "th line:\n";
print "> $a1[$_]> $a2[$_]";
print "-----\n";
}
exit 0;
[/code:1:d789d34a35]

--------------------------------------------------------------------------------
deathcult 回复于：2003-08-25 17:21:25
[b:cefde0ba99](35) Algorithm::Diff, diff()[/b:cefde0ba99]

用于文件比较。
实现类似unix command [b:cefde0ba99]diff[/b:cefde0ba99]的功能。

[code:1:cefde0ba99]
#!/usr/bin/perl

use Algorithm::Diff qw(diff);

die("Usage: $0 file1 file2\n") if @ARGV != 2;

my ($file1, $file2) = @ARGV;
-T $file1 or die("$file1: binary\n");
-T $file2 or die("$file2: binary\n");

@f1 = `cat $file1 `;
@f2 = `cat $file2 `;

$diffs = diff(\@f1, \@f2);

foreach $chunk (@$diffs)
{
foreach $line (@$chunk)
{
my ($sign, $lineno, $text) = @$line;
printf "$sign%d %s", $lineno+1, $text;
}

print "--------\n";
}

[/code:1:cefde0ba99]

--------------------------------------------------------------------------------
deathcult 回复于：2003-09-01 14:35:19
[b:e80702beaa](36) List::Util, max(), min(), sum(), maxstr(), minstr()...[/b:e80702beaa]

列表实用工具集。

[code:1:e80702beaa]
#!/usr/bin/perl

use List::Util qw/max min sum maxstr minstr shuffle/;

@s = ('hello', 'ok', 'china', 'unix');

print max 1..10; #10
print min 1..10; #1
print sum 1..10; #55
print maxstr @s; #unix
print minstr @s; #china
print shuffle 1..10; #radom order

[/code:1:e80702beaa]

--------------------------------------------------------------------------------
deathcult 回复于：2003-09-02 16:46:05
[b:92dc80529e](37) HTML::Parser[/b:92dc80529e]

解析HTML。本例为找出一个html文本中的所有图片的地址。（即IMG标签中的src）

子程序start中的"$tag =~ /^img$/"为过滤出img标签。
如果换为"$tag =~ /^a$/"，即是找出所有的链接地址。

详细的方法介绍，请见`perldoc HTML::Parser`

[code:1:92dc80529e]

#!/usr/bin/perl

use LWP::Simple;
use HTML::Parser;

my $url = shift "http://www.chinaunix.net/";
my $content = LWP::Simple::get($url) or die("unknown url\n");

my $parser = HTML::Parser->new(
start_h => [\&start, "tagname, attr"],
);

$parser->parse($content);
exit 0;

sub start
{
my ($tag, $attr, $dtext, $origtext) = @_;
if($tag =~ /^img$/)
{
if (defined $attr->{'src'} )
{
print "$attr->{'src'}\n";
}
}
}

[/code:1:92dc80529e]

--------------------------------------------------------------------------------
deathcult 回复于：2003-09-04 14:46:21
[b:f1c554421e](38) Mail::Sender[/b:f1c554421e]

（1）发送附件

[code:1:f1c554421e]

#!/usr/bin/perl

use Mail::Sender;

$sender = new Mail::Sender{
smtp => 'localhost',
from => 'xxx@localhost'
};
$sender->MailFile({
to => '[e-mail]' ,
subject => 'hello',
file => 'Attach.txt'
});
$sender->Close();

print $Mail::Sender::Error eq "" ? "send ok!\n" : $Mail::Sender::Error;

[/code:1:f1c554421e]

--------------------------------------------------------------------------------
deathcult 回复于：2003-09-04 14:59:54
（2）发送html内容

[code:1:e18a1aa1d8]

#!/usr/bin/perl

use Mail::Sender;

open(IN, "< ./index.html") or die("");

$sender = new Mail::Sender{
smtp => 'localhost',
from => 'xxx@localhost'
};

$sender->Open({
to => '[e-mail]',
subject => 'xxx',
msg => "hello!",
ctype => "text/html",
encoding => "7bit",
});

while(<IN>)
{
$sender->SendEx($_);
}
close IN;
$sender->Close();

print $Mail::Sender::Error eq "" ? "send ok!\n" : $Mail::Sender::Error;

[/code:1:e18a1aa1d8]

发送带有图片或其他信息的html邮件，请看`perldoc Mail::Sender`
中的"Sending HTML messages with inline images"及相关部分。