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

deathcult

提供者：flora

(29) Bio::DB::GenBank, Bio::SeqIO

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

1. 
   
2. #!/usr/bin/perl -w
   
3. 
   
4. use Bio::DB::GenBank;
   
5. use Bio::SeqIO;
   
6. my $gb = new Bio::DB::GenBank;
   
7. 
   
8. my $seqout = new Bio::SeqIO(-fh =>; \*STDOUT, -format =>; 'fasta');
   
9. 
   
10. 
    
11. # if you want to get a bunch of sequences use the batch method
    
12. my $seqio = $gb->;get_Stream_by_id([ qw(27501445 2981014)]);
    
13. 
    
14. while( defined ($seq = $seqio->;next_seq )) {
    
15.         $seqout->;write_seq($seq);
    
16. }
    

复制代码

deathcult

提供者：flora

（30） Spreadsheet:arseExcel
perl解析Excel文件的例子。

1. 
   
2. #!/usr/bin/perl -w
   
3. 
   
4. use strict;
   
5. use Spreadsheet::ParseExcel;
   
6. use Spreadsheet::ParseExcel::FmtUnicode; #gb support
   
7. 
   
8. my $oExcel = new Spreadsheet::ParseExcel;
   
9. 
   
10. die "You must provide a filename to $0 to be parsed as an Excel file" unless @ARGV;
    
11. my $code = $ARGV[1] || "CP936"; #gb support
    
12. my $oFmtJ = Spreadsheet::ParseExcel::FmtUnicode->;new(Unicode_Map =>; $code); #gb support
    
13. my $oBook = $oExcel->;Parse($ARGV[0], $oFmtJ);
    
14. my($iR, $iC, $oWkS, $oWkC);
    
15. print "FILE  :", $oBook->;{File} , "\n";
    
16. print "COUNT :", $oBook->;{SheetCount} , "\n";
    
17. 
    
18. print "AUTHOR:", $oBook->;{Author} , "\n"
    
19. if defined $oBook->;{Author};
    
20. 
    
21. for(my $iSheet=0; $iSheet < $oBook->;{SheetCount} ; $iSheet++)
    
22. {
    
23. $oWkS = $oBook->;{Worksheet}[$iSheet];
    
24. print "--------- SHEET:", $oWkS->;{Name}, "\n";
    
25. for(my $iR = $oWkS->;{MinRow} ;
    
26.      defined $oWkS->;{MaxRow} && $iR <= $oWkS->;{MaxRow} ;
    
27.      $iR++)
    
28. {
    
29.   for(my $iC = $oWkS->;{MinCol} ;
    
30.       defined $oWkS->;{MaxCol} && $iC <= $oWkS->;{MaxCol} ;
    
31.       $iC++)
    
32.   {
    
33.    $oWkC = $oWkS->;{Cells}[$iR][$iC];
    
34.    print "( $iR , $iC ) =>;", $oWkC->;Value, "\n" if($oWkC);
    
35.   }
    
36. }
    
37. }
    

复制代码

deathcult

(31) Text::CSV_XS, parse(), fields(), error_input()

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

1. 
   
2. #!/usr/bin/perl
   
3. 
   
4. use strict;
   
5. use Text::CSV_XS;
   
6. 
   
7. my @columns;
   
8. my $csv = Text::CSV_XS->;new({
   
9.                                                         'binary' =>; 1,
   
10.                                                         'quote_char'  =>; '"',
    
11.                                         'sep_char'    =>; ','               
    
12.                                                         });  
    
13. 
    
14. foreach my $line(<DATA>;)
    
15. {
    
16.         chomp $line;
    
17.         if($csv->;parse($line))
    
18.         {
    
19.                 @columns = $csv->;fields();
    
20.         }
    
21.         else
    
22.         {
    
23.                 print "[error line : ", $csv->;error_input, "]\n";
    
24.         }
    
25. 
    
26.         map {printf("%-14s\t", $_)} @columns;
    
27.         print "\n";
    
28. }
    
29. exit 0;
    
30. 
    
31. __DATA__
    
32. id,compact_sn,name,type,count,price
    
33. 37,"ITO-2003-011","台式机,compaq","128M","290","1,2900"
    
34. 35,I-BJ-2003-010,"显示器,硬盘,内存",'三星',480,"1,4800"
    
35. 55,"C2003-104",笔记本,"Dell,Latitude,X200",13900,"1,13900"
    

复制代码

deathcult

提供者：Apile

(32) Benchmark

1. 
   
2. #!/usr/bin/perl
   
3. 
   
4. use Benchmark;
   
5. 
   
6. timethese(100,
   
7.         {
   
8.                 'local'=>;q
   
9.                                 {
   
10.                                         for(1..10000)
    
11.                                         {
    
12.                                                 local $a=$_;
    
13.                                                 $a *= 2;
    
14.                                         }
    
15.                                 },
    
16. 
    
17.                 'my'=>;q
    
18.                         {
    
19.                                 for(1..10000)
    
20.                                 {
    
21.                                         my $a=$_;
    
22.                                         $a *= 2;
    
23.                                 }
    
24.                         }
    
25.         });
    

复制代码

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

deathcult

(33) HTTP:aemon, accept(), get_request(), send_file_response()

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

1. 
   
2. #!/usr/bin/perl
   
3. 
   
4. use HTTP::Daemon;
   
5. 
   
6. $| = 1;
   
7. my $wwwroot = "/home/doc/";
   
8. my $d = HTTP::Daemon->;new || die;
   
9. print "Perl Web-Server is running at: ", $d->;url, " ...\n";
   
10. 
    
11. while (my $c = $d->;accept)
    
12. {       
    
13.         print $c "Welcome to Perl Web-Server<br>;";
    
14. 
    
15.     if(my $r = $c->;get_request)
    
16.         {               
    
17.                 print "Received : ", $r->;url->;path, "\n";
    
18.                 $c->;send_file_response($wwwroot.$r->;url->;path);
    
19.     }
    
20. 
    
21.     $c->;close;
    
22. }
    

复制代码

deathcult

(34) Array::Compare, compare(), full_compare()

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

1. 
   
2. #!/usr/bin/perl
   
3. 
   
4. use Array::Compare;
   
5. 
   
6. $comp = Array::Compare->;new(WhiteSpace =>; 1);
   
7. $cmd = "top -n1 | head -4";
   
8. @a1 = `$cmd`;
   
9. @a2 = `$cmd`;
   
10. 
    
11. @result = $comp->;full_compare(\@a1, \@a2);
    
12. 
    
13. foreach(@result)
    
14. {
    
15.         print $_ + 1, "th line:\n";
    
16.         print ">; $a1[$_]>; $a2[$_]";
    
17.         print "-----\n";
    
18. }
    
19. exit 0;
    

复制代码

deathcult

(35) Algorithm:iff, diff()

用于文件比较。
实现类似unix command diff的功能。

1. 
   
2. #!/usr/bin/perl
   
3. 
   
4. use Algorithm::Diff qw(diff);
   
5. 
   
6. die("Usage: $0 file1 file2\n") if @ARGV != 2;
   
7. 
   
8. my ($file1, $file2) = @ARGV;
   
9. -T $file1 or die("$file1: binary\n");
   
10. -T $file2 or die("$file2: binary\n");
    
11. 
    
12. @f1 = `cat $file1 `;
    
13. @f2 = `cat $file2 `;
    
14. 
    
15. $diffs = diff(\@f1, \@f2);
    
16. 
    
17. foreach $chunk (@$diffs)
    
18. {
    
19.         foreach $line (@$chunk)
    
20.         {
    
21.                 my ($sign, $lineno, $text) = @$line;
    
22.             printf "$sign%d %s", $lineno+1, $text;
    
23.         }
    
24. 
    
25.         print "--------\n";
    
26. }
    
27. 
    

复制代码

deathcult

(36) List::Util, max(), min(), sum(), maxstr(), minstr()...

列表实用工具集。

1. 
   
2. #!/usr/bin/perl
   
3. 
   
4. use List::Util qw/max min sum maxstr minstr shuffle/;
   
5. 
   
6. @s = ('hello', 'ok', 'china', 'unix');
   
7. 
   
8. print max 1..10;                #10
   
9. print min 1..10;                #1
   
10. print sum 1..10;                #55
    
11. print maxstr @s;                #unix
    
12. print minstr @s;                #china
    
13. print shuffle 1..10;        #radom order
    
14. 
    
15. 
    

复制代码

deathcult

(37) HTML:arser

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

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

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

1. 
   
2. 
   
3. #!/usr/bin/perl
   
4. 
   
5. use LWP::Simple;
   
6. use HTML::Parser;
   
7. 
   
8. my $url = shift || "http://www.chinaunix.net";
   
9. my $content = LWP::Simple::get($url) or die("unknown url\n");
   
10. 
    
11. my $parser = HTML::Parser->;new(
    
12.                         start_h =>; [\&start, "tagname, attr"],
    
13.                         );
    
14. 
    
15. $parser->;parse($content);
    
16. exit 0;
    
17. 
    
18. sub start
    
19. {
    
20.         my ($tag, $attr, $dtext, $origtext) = @_;       
    
21.         if($tag =~ /^img$/)
    
22.         {       
    
23.                 if (defined $attr->;{'src'} )
    
24.                 {
    
25.                         print "$attr->;{'src'}\n";       
    
26.                 }
    
27.         }
    
28. }
    
29. 
    

复制代码

deathcult

(38) Mail::Sender

（1）发送附件

1. 
   
2. 
   
3. #!/usr/bin/perl
   
4. 
   
5. use Mail::Sender;
   
6. 
   
7. $sender = new Mail::Sender{
   
8.                                                         smtp =>; 'localhost',
   
9.                                                         from =>; 'xxx@localhost'
   
10.                                                         };
    
11. $sender->;MailFile({
    
12.                                         to =>; 'xxx@xxx.com',
    
13.                                         subject =>; 'hello',
    
14.                                         file =>; 'Attach.txt'
    
15.                                         });
    
16. $sender->;Close();
    
17. 
    
18. print $Mail::Sender::Error eq "" ? "send ok!\n" : $Mail::Sender::Error;
    
19. 
    
20. 
    

复制代码