[devel]

提供者：flora

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

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

PHP 代码:

#!/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);
} 


[devel]

提供者：flora

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

PHP 代码:

#!/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);
  }
}
} 


[devel]

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

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

PHP 代码:

#!/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"

[devel]

提供者：Apile

(32) Benchmark

PHP 代码:

#!/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;
            }
         }
   }); 


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

[devel]

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

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

PHP 代码:

#!/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;
} 


[devel]

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

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

PHP 代码:

#!/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; 


[devel]

(35) Algorithm::Diff, diff()

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

PHP 代码:

#!/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";
} 


[devel]

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

列表实用工具集。

PHP 代码:

#!/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 


[devel]

(37) HTML::Parser

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

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

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

PHP 代码:

#!/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";   
      }
   }
} 


[devel]

(38) Mail::Sender

（1）发送附件

PHP 代码:

#!/usr/bin/perl

use Mail::Sender;

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

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


[devel]

（2）发送html内容

PHP 代码:

#!/usr/bin/perl

use Mail::Sender;

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

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

$sender->Open({
               to => 'xxx@xxx.com',
               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; 


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

[devel]

40 Image::Magick
提供者：
http://www.imagemagick.org/www/perl.html

#!/usr/local/bin/perl
    use Image::Magick;

    my($image, $x);

    $image = Image::Magick->new;
    $x = $image->Read('girl.png', 'logo.png', 'rose.png');
    warn "$x" if "$x";

    $x = $image->Crop(geometry=>'100x100"+100"+100');
    warn "$x" if "$x";

    $x = $image->Write('x.png');
    warn "$x" if "$x";

The script reads three images, crops them, and writes a single image as a GIF animation sequence. In many cases you may want to access individual images of a sequence. The next example illustrates how this is done:

    #!/usr/local/bin/perl
    use Image::Magick;

    my($image, $p, $q);

    $image = new Image::Magick;
    $image->Read('x1.png');
    $image->Read('j*.jpg');
    $image->Read('k.miff[1, 5, 3]');
    $image->Contrast();
    for ($x = 0; $image->[x]; $x++)
    {
      $image->[x]->Frame('100x200') if $image->[x]->Get('magick') eq 'GIF';
      undef $image->[x] if $image->[x]->Get('columns') < 100;
    }
    $p = $image->[1];
    $p->Draw(stroke=>'red', primitive=>'rectangle', points=>20,20 100,100');
    $q = $p->Montage();
    undef $image;
    $q->Write('x.miff');

Suppose you want to start out with a 100 by 100 pixel white canvas with a red pixel in the center. Try

    $image = Image::Magick->new;
    $image->Set(size=>'100x100');
    $image->ReadImage('xc:white');
    $image->Set('pixel[49,49]'=>'red');

Or suppose you want to convert your color image to grayscale:

    $image->Quantize(colorspace=>'gray');

Here we annotate an image with a Taipai TrueType font:

    $text = 'Works like magick!';
    $image->Annotate(font=>'kai.ttf', pointsize=>40, fill=>'green', text=>$text);

Other clever things you can do with a PerlMagick objects include

    $i = $#$p"+1";   # return the number of images associated with object p
    push(@$q, @$p);  # push the images from object p onto object q
    @$p = ();        # delete the images but not the object p
    $p->Convolve([1, 2, 1, 2, 4, 2, 1, 2, 1]);   # 3x3 Gaussian kernel

[devel]

41.Data::SearchReplace

         use Data::SearchReplace ('sr');
         sr({ SEARCH => 'searching', REPLACE => 'replacing'}, \$complex_var);
                                                                                                 
         # or OO
                                                                                                 
         use Data::SearchReplace;
         $sr = Data::SearchReplace->new({ SEARCH => 'search for this',
                                          REPLACE => 'replace with this' });
                                                                                                 
         $sr->sr(\$complex_var);
         $sr->sr(\$new_complex_var);
                                                                                                 
         # if you want more control over your search/replace pattern you
         #  can pass an entire regex instead complete with attributes
                                                                                                 
         sr({ REGEX => 's/nice/great/gi' }, \$complex_var);
                                                                                                 
         # you can even use a subroutine if you'd like
         #  the input variable is the value and the return sets the new
         #  value.
                                                                                                 
         sr({ CODE => sub { uc($_[0]) } }, \$complex_var);

        use Data::SearchReplace qw(sr);
        sr({SEARCH => 'find', REPLACE => 'replace'}, \@data);
        sr({REGEX  => 's/find/replace/g'}, \%data);
        sr({CODE   => sub {uc($_[0])} }, \@data);

[sgm277]

为啥我make的时候提示我make不是内部或外部命令呢?我是在windows下装的perl.高手给指点一下

[yuio654]

这帖不顶对不住楼主！！！