Chinaunix首页 | 论坛 | 博客
  • 博客访问: 4288
  • 博文数量: 1
  • 博客积分: 0
  • 博客等级: 民兵
  • 技术积分: 25
  • 用 户 组: 普通用户
  • 注册时间: 2014-12-31 10:53
文章分类

全部博文(1)

文章存档

2015年(1)

我的朋友
最近访客

分类: PERL

2015-01-06 17:43:17

(1) Net::FTP
(2) Net::Telnet
(3) LWP::Simple, get()
(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()
(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
(39) Time::HiRes, gettimeofday(), usleep()
(40) Image::Magick


(41) Data::SearchReplace










(1)Net::FTP


#!/usr/bin/perl -w
# file: ftp_recent.pl
# Figure 6.1: Downloading a single file with Net::FTP
use Net::FTP;


use constant HOST => 'ftp.perl.org';
use constant DIR => '/pub/CPAN';
use constant FILE => 'RECENT';


my $ftp = Net::FTP->new(HOST) or die "Couldn't connect: $@\n";
$ftp->login('anonymous') or die $ftp->message;
$ftp->cwd(DIR) or die $ftp->message;
$ftp->get(FILE) or die $ftp->message;
$ftp->quit;


warn "File retrieved successfully.\n";








(2) Net::Telnet


#!/usr/bin/perl -w
# file:remoteps.pl


use strict;
use Net::Telnet;
use constant HOST => 'phage.cshl.org';
use constant USER => 'lstein';
use constant PASS => 'xyzzy';


my $telnet=Net::Telnet->new(HOST);
$telnet->login(USER,PASS);
my @lines=$telnet->cmd('ps -ef');
print @lines;




(3) LWP::Simple, get()


#!/usr/bin/perl -w
use strict;
use LWP::Simple qw(get);


my $url = shift || "";
my $content = get($url);


print $content;


exit 0;
#最简单方便的get网页的方法。




(4) Expect


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




(5) XML::Simple, XMLin()


#!/usr/bin/perl -w
use strict;
use XML::Simple;
my $text = < < ?xml version="1.0"? >


php
net.php.servlet


php
*.php


xml
my $x = XMLin($text);
foreach my $tag(keys %$x)
{
my %h = %{$$x{$tag}};
foreach(keys %h)
{
print "$tag => ";
print "$_ => $h{$_}\n";
}
}
exit 0;




(6) Data::Dumper, Dumper()


#!/usr/bin/perl -w
use strict;
use Data::Dumper;


print Dumper(@INC);
print Dumper(%ENV);
exit 0;




(7) IO::Socket


#!/usr/bin/perl -w
use strict;
use IO::Socket;


my $host = "";
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;




(8) Date::Manip, DateCalc(), UnixDate()


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




(9) Date::Manip, Date_Cmp()






(10) File::Find, find()




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


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


(11) ExtUtils::Installed, new(), modules(), version()


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




(12) DBI, connect(), prepare(), execute(), fetchrow_array()


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






(13) Getopt::Std


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




(14) Proc::ProcessTable


#直接访问Unix进程表,类似ps command。


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




(15) Shell


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


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




(16) Time::HiRes, sleep(), time()


#!/usr/bin/perl
#Another use of Time::HiRes Module.


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;


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




(17) HTML::LinkExtor, links(), parse_file()


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


"">



CPAN






















alt="[CPAN Logo]" height="121" width="250"/>





2003-06-10 online since 1995-10-26
1662 MB 246 mirrors
2903 authors 4767 modules



Welcome to CPAN! Here you will find All Things Perl.




























Browsing








Searching







FAQ etc








Yours Eclectically, The Self-Appointed Master Librarian (OOK!) of the CPAN

Jarkko Hietaniemi
cpan@perl.org
[Disclaimer] _fcksavedurl=""disclaimer.html">[Disclaimer]"





































CPAN master site hosted by


FUNET













(18) Net::Telnet, open(), print(), getline()


#!/usr/bin/perl
use strict;
use Net::Telnet;


my $p = Net::Telnet->new();
my $h = shift || "";


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




(19) Compress::Zlib, gzopen(), gzreadline(), gzclose()


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


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




(20) Net::POP3, login(), list(), get()


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


telnet pop3.web.com 110 也可以直接连到pop3 server上,然后通过pop3命令与邮件服务器交互,


简单的命令有:




QUOTE:USER name
PASS string
STAT
LIST [n]
RETR msg
DELE msg
NOOP
RSET
QUIT




有兴趣的朋友可以试一试。
这样,也就可以利用Net::Telnet来做一个收信件的简单程序。






(21) Term::ANSIColor


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


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


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




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




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




(22) Date::Calc Calendar(), Today()


#!/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[5me[31m$daye[0m/;


print $cal;
exit 0;


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


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


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


颜色和闪烁是用ANSI escape sequences。
详细说明尽在ANSIColor.pm source和perldoc Term::ANSIColor里。
(perldoc Term::ANSIColor其实也在ANSIColor.pm source里) :)








(23) Term::Cap, Tgetend(), Tgoto, Tputs()


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


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






(24) HTTPD::Log::Filter


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


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






QUOTE:use HTTPD::Log::Filter;
print HTTPD::Log::Filter->new(format=>"CLF",capture=>['request'])->re;




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






(25) Net::LDAP


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




LDAP version 3..可以用于查询基本资料、验证密码之用..




(26) Net::SMTP mail(), to(), data(), datasend(), auth()


#!/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('some@some.com');
$smtp->data("chinaunix,哈楼你好啊!\n:)");
$smtp->quit;


exit 0;




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






(27) MIME::Base64, encode_base64(), decode_base64()


#!/usr/bin/perl -w


use strict;
use MIME::Base64;


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


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




用来处理MIME/BASE64编码。






(28) Net::IMAP::Simple, login(), mailboxes(), select(), get()...


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




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


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






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




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


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






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




(30) Spreadsheet::ParseExcel


perl解析Excel文件的例子。






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




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


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






QUOTE:#!/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()
{
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"




(32) Benchmark


#!/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耗费多少时间.




QUOTE:timethese(做几次iteration,{
'Algorithm名稱'=>q{ 要计算时间的algorithm },
'Algorithm名稱'=>q{ 要计算时间的algorithm }
});






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


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




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


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


$c->close;
}




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


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




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




(35) Algorithm::Diff, diff()


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


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




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


列表实用工具集。




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




(37) HTML::Parser


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


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


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






QUOTE:#!/usr/bin/perl


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


my $url = shift || "";
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";
}
}
}




(38) Mail::Sender


1)发送附件






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




2)发送html内容






QUOTE:#!/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()
{
$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"及相关部分。






(39) Time::HiRes, gettimeofday(), usleep()
(40) Image::Magick




http://www.imagemagick.org/www/perl.html






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






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






QUOTE:$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:






QUOTE:$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






QUOTE:$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




(41) Data::SearchReplace




#!/user/bin/perl
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);






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




阅读(2150) | 评论(0) | 转发(0) |
0

上一篇:没有了

下一篇:没有了

给主人留下些什么吧!~~