perl LWP 网络编程

来源：互联网发布：cpda数据分析师培训编辑：程序博客网时间：2024/05/17 06:52

php perl 不用表单模拟 POST请求

php 不用表单模拟 POST请求

复制PHP内容到剪贴板

PHP代码:

/**

* @name php 发送POST请求

* @param string $url 提交到的地址

* @param array $data 要提交的参数 array('a'=>'','b'=>'');

* @return string

function posttohost($url, $data) {

$url = parse_url($url);

if (!$url) return "couldn't parse url";

if (!isset($url['port'])) $url['port'] = "";

if (!isset($url['query'])) $url['query'] = "";

$encoded = "";

while (list($k,$v) = each($data)) {

$encoded .= ($encoded ? "&" : "");

$encoded .= rawurlencode($k)."=".rawurlencode($v);

}

$fp = fsockopen($url['host'], $url['port'] ? $url['port'] : 80);

if (!$fp) return "Failed to open socket to $url[host]";

fputs($fp, sprintf("POST %s%s%s HTTP/1.0/n", $url['path'], $url['query'] ? "?" : "", $url['query']));

fputs($fp, "Host: $url[host]/n");

fputs($fp, "Content-type: application/x-www-form-urlencoded/n");

fputs($fp, "Content-length: " . strlen($encoded) . "/n");

fputs($fp, "Connection: close/n/n");

fputs($fp, "$encoded/n");

$line = fgets($fp,1024);

if (!eregi("^HTTP/1/.. 200", $line)) return;

$results = ""; $inheader = 1;

while(!feof($fp)) {

$line = fgets($fp,1024);

if ($inheader && ($line == "/n" || $line == "/r/n")) {

$inheader = 0;

}elseif (!$inheader) {

$results .= $line;

}

fclose($fp);

return $results;

}

perl 不用表单模拟 POST请求

代码:

#!/usr/bin/perl

use HTTP::Request::Common qw(POST);

use LWP::UserAgent;

$ua = LWP::UserAgent->new();

my $url="http://www.***.net/act.php"; 提交到的action网页

my $referer = ""; # 表单所在网页

my $arg={

'username' => 'user',

'password' => 'Pass',

Referer = $referer;

};

sub perlPOST(){

my($arg,$url)=@_;

$resp = $ua->post($url,$arg,'Content_Type' => 'form-data');

$content = $resp->content;

print $content;

}

&perlPOST($arg,$url);

LWP( Library for Web access in Perl) 能做到什么？ 1. 使用URL对远程Web Server读取文件。 2. 对Web Serve利用POST 方式送出form request。 3. 对远程Webserver最近更新的文件作更新动作。 4. 解析HTML 文件，取得其中的「连结」与一些需要的数据。 5. 将HTML转成纯文本文件或Postscript档案。 6. 处理cookies,HTTP redirects, proxy servers, and HTTP user authentication.这些特殊事件。重要特性： 1.包含许多可重复使用的组件，可独立运作或相互配合使用. 提供一个HTTP-style沟通的Object Oriented模型。支援 http, https, gopher, ftp, news, file, and mailto resources. 2.提供完整的OO接口。 3.支持基本的编码与认证功能 4.支持重新导向处理。 5.可以透过代理服务器(Proxy server) 6.可以透过robots.txt建构robots。有点类似网络上的爬虫程序。 7.实作HTTP的content negotiation algorithm 可以与CGI程序作界接。 8.支援 HTTP cookies. 8.有一个简单的指令格式应用程序: lwp-request. 安装时，要求先要安装的modules： URI URL parsing and manipulation Net::FTP to support ftp:// URLs MIME::Base64 to support HTTP Basic authentication Digest::MD5 to support HTTP Digest authentication HTML::HeadParser for finding the <BASE> tag in HTML headers (实际上更多，因为要安装上述module可能还要先安装其它modules) #--比较建议这种方式安装，但是如果不能对外连结，只好跟我一样慢慢抓modules，一个一个安装用CPAN方法安装： #perl -MCPAN -e 'install Bundle::LWP' 除了上面的模块外，另外还要安装 #perl -MCPAN -e 'install HTML::Parser' -e 'install HTML::Formatter' 如果不用CPAN方式安装： HTML-Parser HTML Parser HTML-Tree HTML syntax-tree generation Font-AFM Postscript font metrics HTML-Format HTML Formatting 一定要要下载并安装上述modules.. 如果要使用HTTPS必须要安装IO ::Socket ::SSL and OpenSSL library(http://www.openssl.org) 安装完LWP后，会帮你安装四个scripts lwp-request 取得url并显示出来 lwp-download 下载文件到硬盘，适合大档案使用。 lwp-mirror 与远程的服务器的文件作镜射动作，只更新最近有被改变的文件。 Lwp-rget 递回的取得整个档案架构 LWP基础程序： #!/usr/bin/perl # file get_url.pl #--开启语法检查并使用LWP modules use strict; use LWP; #--取得URL my $url = shift; #--建立LWP ::UserAgent 与HTTP ::Request 物件， #--其中Request对象将$url传进去 my $agent=LWP::UserAgent->new(); my $request = HTTP::Request->new(GET=>$url); #--透过UserAgent的request method将Request送出 my $response= $agent->request($request); #--检查是否有error发生 $response->is_success or die "$url: ",$response->message,"/n"; #--显示responser的内容 print $response->content; 其中HTTP ::Request Object可以很简单的只有一个URL也可以很复杂的包含cookies、authentication information与CGI script所需要的arguments。 HTTP ::Response对象，主要将Server回传的结果打包起来，其包含执行结果状态的信息加上文件内容。 LWP ::UserAgent 为一个介于Client与Server中间的媒介，负责传送Request至Server，并将Server的回传值解析后存入HTTP ::Response Object中。另外也可以使用LWP ::Simple的Modules也可以作相同的事情。 # !/usr/bin/perl # file simple_get.pl use LWP ::Simple ; my $url = shift; #--如果正常会显示内容，否则 getprint($url); LWP中最重要的三个对象：HTTP::Request、HTTP::Response、LWP::UserAgent。以下分别针对这三个modules作说明。 LWP Modules里面Modules间的概观： LWP::MemberMixin -- Access to member variables of Perl5 classes LWP::UserAgent -- WWW user agent class LWP::RobotUA -- When developing a robot applications LWP::Protocol -- Interface to various protocol schemes LWP::Protocol::http -- http:// access LWP::Protocol::file -- file:// access LWP::Protocol::ftp -- ftp:// access ... LWP::Authen::Basic -- Handle 401 and 407 responses LWP::Authen::Digest HTTP::Headers -- MIME/RFC822 style header (used by HTTP::Message) HTTP::Message -- HTTP style message HTTP::Request -- HTTP request HTTP::Response -- HTTP response HTTP::Daemon -- A HTTP server class WWW::RobotRules -- Parse robots.txt files WWW::RobotRules::AnyDBM_File -- Persistent RobotRules Net::HTTP -- Low level HTTP client 在Web 服务的典型中，所有Client与Server的交互作用分为Client的request与Server的reponse HTTP::Request： Client的request包含URL与所使用的method。事实上HTTP::Rquset使用的是URI(Uniform Resource Identifier)包含了通讯协议与连结的服务器。通讯协议： HTTP(http://www.abc:port/path/)、FTP(ftp://ftpname:port/path)、 GOPHER(gopher:://gophername:port/path)、SMTP(mailto:user@mailserver)、 NEWS(news:message-id) 这个modules支持的方法： GET 取得URL的文件(web page) PUT 替代或建立URL上的文件(ftp) POST 送出事先准备好的Form至Server处。 DELETE 删除URL上的文件(FTP Server) HEAD 取得URL的信息 HTTP协议包含其它信息：(RFC 822-like 字段)这里只有部分： Accept 指出client准备送出的MIME型态 User-agent Client软件的名称与版本 Content-type Request的文件型态 PUT与POST method：Request可以包含文件内容（content data）。 PUT：包含要上传的到URL的文件内容。 POST：包含已经填好的要送出至CGI Script的Form。 LWP使用HTTP::Request表示所有经由LWP所发送出去的的Request，不是只有HTTP也可以包含FTP、NNTP、SMTP等协议。 Method的说明： $request=HTTP::Request->new($method,$url[,$header[,$content]]) 建构HTTP::Request物件。最少要两个自变量（$method与$url）。$URL可以是URI对象。Header与content可以对象建立后再补数据。 $request->header($field1=>$val1,$feild2=>$val2..) 设定$field数值。 @values=$request->header($field)：取得某个field里面的所有数值。可以是list也可以是scalar variable用","分隔的Variable。 $request->push_header($filed=>$value) 将$field与$value加入在header最后面 $request->remove_header(@fields) 删掉特定的fields $request->scan(/?) 对每个HTTP header作迭代每个element都丢入? function中，主要传入field数值与value数值。从HTTP::Header modules中继承来的method.. $request->date()：设定时间 $request->expires()：设定过期时间 $request->last_modified()：设定resources最后修改时间 $request->if_modified_since()：检查是否从$date后有被修正过。 $request->content_type()：设定讯息内容的形式 $request->content_length()：设定讯息的长度 $request->referrer()：设定Used to specify the address (URI) of the document from which the requested resouce address was obtained. $request->user_agent()：Client端的软件与版本 $request->content([$content]) 设定requset的内容，可以是一个subroutine，LWP会不断invoke这个function直到回传null数值。 $request->content_ref 回传ref to content，可以直接修改内容 $requese->add_content($data) 增加content内容改变URL内容与method： $request->uri([$uri]) 设定或取出URI内容 $request->method([$method]) 设定或取出method内容 $string=$request->as_string 将request内容以文字方式显示出来一些例子：发送Email： $req = HTTP::Request->new(POST => 'mailto:libwww@perl.org'); $req->header(Subject => "subscribe"); $req->content("Please subscribe me to the libwww-perl mailing list!/n"); FTP档案： $req = HTTP::Request->new(GET => 'file:/etc/passwd'); 与NEWS Server作用： $req = HTTP::Request->new(GET => 'news:abc1234@a.sn.no'); $req = HTTP::Request->new(POST => 'news:comp.lang.perl.test'); $req->header(Subject => 'This is a test', From => 'me@some.where.org'); $req->content(<<EOT); This is the content of the message that we are sending to the world. EOT CPAN Request： $LWP::Protocol::cpan::CPAN = "file:/local/CPAN/"; HTTP::Response物件： HTTP::Reponse接收服务器的回应值，没有限定一定要是HTTP协议。回传的状态码，不管是不是HTTP都回传下列数值： 100-199 状态码从100到199，为要求完成前的状态码 200-299 成功 300-399 重新转向，URL已经被移动至其它地方。 400-499 Client-side 错误 500以上 Server-side 错误如果Server回传301 或 302，则LWP会对新的URL发出要求，所以回传值，是针对新的URL并非针对旧的URL。如果Server回传401需要Authorization，而且Authorization信息也存在，则LWP会重新发送存在Authorization的Request到Server端。 HTTP::Response有一个建构子(contructor)，但是因为不会去呼叫他，所以以下并没有列出建构子。 $status_code = $response->code $status_message=$response->message code()回传状态码，message()回传讯息明码内容，也可以给他参数设定他的数值。 $text=$response->status_line 回传与Web Server传回的内容一样的数值，状态码加上讯息内容。 $boolean=$response->is_success 是否成功 $boolean=$response->is_redirect 是否重新转向 $boolean=$response->is_info 是否是information $boolean=$response->is_error 是否有错误 $html=$response->error_as_HTML 当is_error为真的时候，利用error_as_HTML产成HTML格式的错误讯系 $base=$response->base 回传base的URL。实际上回传URI对象，可用来解析relative的links。 $request=$response->request 回传HTTP::Request 物件。如果有redirect或authentication则对象内容会与原本的不一样。 $request=$reponse->previous 回传HTTP::Request对象，可以在一连串redirect之后找到原始的HTTP::Request对象内容。下面是一个找出所有转向过程的Script： #!/usr/bin/perl #file follow_chain.pl use strict; use LWP; my $url = shift; my $agent = LWP::UserAgent->new(); my $request=HTTP::Request->new(HEAD=>$url); my $response=$agent->request($request); $response->is_success or die "$url: ", $response->message,"/n"; my @urls; for(my $r = $response; defined $r; $r=$r->previous){ unshift @urls,$r->request->uri.'('.$r->status_line.')'; } print "Response chain:/n /t",join("/n/t-> ",@urls),"/n"; LWP ::UserAgent物件： LWP ::UserAgent的角色在于传送request至远程的Server，接收Server回传值并将之放入HTTP ::Response物件中。其实可以把他当成是一个Web Browser engine。跟一般的Web browser一样，LWP ::UserAgent可以知道对方的Document是否有更新、储存Cookies、与相对应的authentication并可以透过http Proxy与其它Server相通。 UserAgent通常会被其它Class继承，以适应不同的远程Server内容。 $agent=LWP ::UserAgent->new 建立LWP ::UserAgent物件 $response=$agent->request($request,[$dest[,$size]]) 产生Request，并将结果存入$response中。透过$response->code与$response->is_success()可以知道是否有成功。 $dest为一个filename，所取得的文件会存在这个地方，$response只存是否成功没有内容；如果没给，会回传至$response。也可以是callback subroutine， $response=$agent->request($request,/&handle_content); sub handle_content{ my ($data,$response,$protocol) = @_; … } $data :current chunk of data $response: HTTP::Response 物件 $protocol: LWP::Protocol 物件当使用ref to code的时候，可以利用$size控制chunk的大小。例如128，则callback subtine每次会读取128 bytes chunks of the content data. 两个request的变形： $response=$agent->simple_request($request,[$dest,[$size]]) 很像request，但是碰到redirect与authentication的时候不会再次产生新的request。 $response=$agent->mirror($url,$file) 接受一个URL与本地储存文件的路径，假如本地文件较旧，则将远程文件抓取回来。设定Request的时间与空间限制 $timeout = $agent->timeout([$timeout]) 设定或读取timeout时间，default 180秒。 $bytes = $agent->max_size([$bytes]) 设定或读取远程Server所能回传的最大空间。Default undef，可以不受限制收取content 增加$request的信息 $id=$agent->agent([$id]) 设定或取出User-Agent:字段。内容像name/x.xx，name是Client software名称。x.xx是版本。Default : lwpwww-perl/x.xx。可以骗remote Server $agent->agent('Mozilla/4.7 [en] (PalmOS)') [在Palm上执行 Mozilla] $address=$agent->from([$address]) 设定或取出负责这个User-Agent的E-mail address，再使用mail或news的时候会填入From: 字段。对HTTP Server的时候不使用这个。与Proxy作用的methods $proxy=$agent->proxy($protocol=>$proxy); 设定或取出proxy server用的protocol与URL。 $protocol可以是一个纯量('ftp')也可以是一个ref to list(['ftp','http','gopher'])。 $proxy是proxy server用的URL。例如： $agent->proxy([qw(ftp http)] => 'http://proxy.abc.cde:8080') 可以再呼叫以修改proxy server的protocol $agent->proxy(ftp => 'http://proxy_1.aaa,bbb:8080'); $agent->proxy(http=>'http://proxy_2.aaa.bbb:8081'); $agent->no_proxy(@domain_list) 设定对某些domain不用proxy server。 $agent->no_proxy('localhost','aaa.bbb'); $agent->no_proxy()：清除所有先前设定的domains $agent->env_proxy 另外一种设定proxy的方法。读取ENV变数(*_proxy)。 Setenv ftp_proxy http://aaa.bbb.ccc:8080 Setenv http_proxy http://aaa.bbb.ccc:8080 Setenv no_proxy localhost,bbb.ccc 控制Authentication与Cookies ($name,$pass) = $agent->get_basic_credentials($realm,$url,[$proxy]) 当proxy server需要认证时，LWP会呼叫这个subroutine，取得username与Password。$realm是realm name是远程Server这个user要求认证的一个关键词，$url是所要Request的URL，$proxy表示是中间proxy要的授权还是远程Server要的授权。这个subroutine回传经由credentials() methods设定的账号密码。 $agent->credentials($hostport,$realm,$name,$pass) 为get_basic_credentials储存username与password。Hostport格式 :$hostname:$port、authentication realm, username and passwd。 $jar=$agent->cookie_jar([$cookie_jar]) default LWP不管cookies。可以把HTTP::Cookies透过cookie_jar将cookies储存起来，以后如果需要cookie的时候可以取出使用。给参数，则$agent设定cookies，若不给参数则$agent回传目前的$cookies(HTTP::Cookies 物件) 储存Cookies的范例：only for this sessions $agent->cookie_jar(new HTTP::Cookies); 将cookies储存到档案中..可以跨Session使用cookies my $file = "$ENV{HOME}/.lwp-cookies"; $agent->cookie_jar(HTTP::Cookies->new(file=>$file,autosave=>1)); 使用Netscape现成的cookies档案，MAC与Windows要作修正： my $files = "$ENV{HOME}/.netscape/cookies"; $agent->cookie_jar(HTTP::Cookies::Netscape->new(file=>file,autosave=>1); 一些例子：取得RFC档案： #!/usr/bin/perl # get_rfc.pl use strict; use LWP; #设定RFCS的URL use constant RFCS => 'http://www.faqs.org/rfcs/'; #至少一个Argument die "Usage: get_rfc.pl rfc1 rfc2.../n" unless @ARGV; #建立LWP::UserAgent Object my $ua = LWP::UserAgent->new; #设定agent ID my $newagent = 'get_rfc/1.0 ('.$ua->agent.')'; #print "$newagent/n"; $ua->agent($newagent); #--主循环 #先建立Request Object，再传入:LWP::UserAgent的request中 while(defined(my $rfc=shift)){ warn "$rfc: invalid RFC number/n" && next unless $rfc=~/^/d+$/; my $request = HTTP::Request->new(GET=>RFCS."rfc$rfc.html"); my $response = $ua->request($request); if($response->is_success){ print $response->content; }else{ warn "RFC $rfc: ",$response->message,"/n"; } } 作Mirror： #!/usr/bin/perl # file: mirror_rfc.pl use strict; use LWP; use constant RFCS => 'http://www.faqs.org/rfcs/'; die "Usage: mirror_rfc.pl rfc1 rfc2.../n" unless @ARGV; my $ua = LWP::UserAgent->new; my $newagent = 'mirror_rfc/1.0 ('.$ua->agent.')'; $ua->agent($newagent); while(defined (my $rfc=shift)){ warn "$rfc: invalid RFC number /n" && next unless $rfc =~ /^/d+$/; my $filename = "rfc$rfc.html"; my $url = RFCS.$filename; #--只检查档案新旧..当有比较新的档案的时候，会将档案回传 my $response = $ua->mirror($url,$filename); print "RFC $rfc: ", $response->message,"/n"; } 送出FORM： http://www.faqs.org/rfcs/ 提供一个搜寻网页，其source code如下： <FORM METHOD=POST ACTION="/cgi-bin/rfcsearch"> <INPUT NAME=query size=25> <SELECT NAME="archive"> <OPTION VALUE="rfcs" SELECTED> Show References <OPTION VALUE="rank"> Rank References <OPTION VALUE="rfcindex"> Search RFC Index <OPTION VALUE="fyiindex"> Search FYI Index <OPTION VALUE="stdindex"> Search STD Index <OPTION VALUE="bcpindex"> Search BCP Index <INPUT TYPE="submit" VALUE="Search RFCs"></TD> </FORM> 针对上面的form送出request，透过URI::Escape将特殊字符给Escape掉 #!/usr/bin/perl # search_rfc.pl use strict; use LWP; use URI::Escape; #--URL of remote search script use constant RFC_SEARCH => 'http://www.faqs.org/cgi-bin/rfcsearch'; #--URL of the page on which the fill-out form is located use constant RFC_REFERER => 'http://www.faqs.org/rfcs/'; #--检查参数是否大于1个 die "Usage: rfc_search.pl term1 term2.../n" unless @ARGV; #--建立LWP::UserAGent 物件 my $ua = LWP::UserAgent->new; #--设定Client Software name与Version my $newagent = 'search_rfc/1.0 ('.$ua->agent.')'; $ua->agent($newagent); #--处理搜寻字符串，产生CGI <form>所需要的搜寻字符串 my $search_terms = "@ARGV"; my $query_string=uri_escape("query=$search_terms&archive=rfcindex"); #print "$query_string/n"; #--建立Request对象，并设定method为POST，url为RFC_SEARCH my $request=HTTP::Request->new(POST=>RFC_SEARCH); #--给订request的内容为$query_string $request->content($query_string); #--告知<form>位于哪儿 $request->referer(RFC_REFERER); #--取得回传值，并解析出需要的内容 my $response = $ua->request($request); die $response->message unless $response->is_success; my $content=$response->content; while($content =~ /(RFC /d+).*<STRONG>(.+)<//STRONG>/g){ print "$1/t$2/n"; } 上述Script存在一个隐藏性Bug，当query_string中存在有&与=的时候，我们需要手动将&转成%26、=转成%3D然后再放入uri_escape中处理，否则会产生错误的query结果。解决方法可以用下面HTTP::Request::Common module. 使用HTTP::Request::Common：因为POST、GET、HEAD、PUT实在是太多人使用了，因此有人开发上面这个module，只要一引用就可以直接使用这四个method。 $request=POST($url[,$form_ref][,$header1=>$val1…]) 回传一个HTTP::Request对象，default使用POST method，$from_ref是一个包含所有names与values的array ref，另外如果有其它header要加入可以follow header/value的格式加入例如： my $request = POST('http://www.faqs.org/cgi-bin/rfcsearch', [query => 'MIME types', archive =>'rfcindex' ] ); 加入Referer的Header： my $request = POST('http://www.faqs.org/cgi-bin/rfcsearch', [ query => 'MIME types', archive => 'rfcindex' ], Referer => 'http://www.faqs.org/rfcs'); 利用Content将form包起来，看起来比较一致性： my $request = POST('http://www.faqs.org/cgi-bin/rfcsearch', Content => [ query => 'MIME types', archive => 'rfcindex' ], Referer => 'http://www.faqs.org/rfcs'); 重新撰写后： #!/usr/bin/perl # search_rfc2.pl use strict; use LWP; use HTTP::Request::Common; use constant RFC_SEARCH => 'http://www.faqs.org/cgi-bin/rfcsearch'; use constant RFC_REFERER => 'http://www.faqs.org/rfcs/'; die "Usage: rfc_search.pl term1 term2.../n" unless @ARGV; my $ua = LWP::UserAgent->new; my $newagent = 'search_rfc/1.0 ('.$ua->agent.')'; $ua->agent($newagent); my $search_terms = "@ARGV"; #--利用HTTP::Request::Common 里面的POST method建立HTTP::Request物件 my $request = POST(RFC_SEARCH, Content => [query => $search_terms, archive => 'rfcindex' ], Referer => RFC_REFERER ); my $response = $ua->request($request); die $response->message unless $response->is_success; my $content=$response->content; while($content =~ /(RFC /d+).*<STRONG>(.+)<//STRONG>/g){ print "$1/t$2/n"; } 上传档案：上传数据时所使用的编码方式与一般的<form>不同。 <FORM METHOD=POST ACTION='/cgi-bin/upload' ENCTYPE='multipart/form-data'> 通常可以从Form中知到用的是哪一种编码。而在LWP中可以透过 My $request = POST('http://www.faqs.org/cgi-bin/rfcsearch', Content_Type =>'form-data', Referer =>'http://www.faqs.org/rfcs', Content => [ query => ' MIME types', archive => 'rfcindex'] ); 一个上传档案的CGI form范例： <form method="post" action="/WWW/software/CGI/examples/file_upload.cgi" enctype="multipart/form-data"> <input type="file" name="filename" size=45> <input type="checkbox" name="count" value="count lines" checked="yes"> <input type="checkbox" name="count" value="count words" checked="yes"> <input type="checkbox" name="count" value="count characters" checked="yes"> <input type="reset"> <input type="submit" name="submit" value="Process File"> <input type="hidden" name=".cgifields" value="count"> </form> 上传的程序： #!/usr/bin/perl use strict; use LWP; use HTTP::Request::Common; use constant WC_SCRIPT => 'http://stein.cshl.org/WWW/software/CGI/examples/file_upload.cgi'; my $file = shift or die "Usage: remote_wc.pl file/n"; my $ua = LWP::UserAgent->new; my $newagent= ' remote_wc/1.0 ('.$ua->agent.')'; $ua->agent($newagent); #--产生request.. my $request = POST(WC_SCRIPT , Content_Type => 'form-data', Content => [ count => 'count lines', count => 'count words', count => 'count characters', '.cgifields' => 'count', submit => 'Process Fiel', filename => [ $file ], ] ); my $response = $ua->request($request); die $response->message unless $response->is_success; my $content=$response->content; my ($lines,$words,$characters) = $content =~ m!Lines:.+?(/d+).+?Words:.+?(/d+).+?Characters:.+(/d+)!; print "lines = $lines; words= $words; characters = $characters/n"; 取得一个被密码保护的网页： #!/usr/bin/perl # get_url2.pl use strict; use LWP; use PromptUtil; use vars '@ISA'; #-继承LWP::UserAgent @ISA='LWP::UserAgent'; my $url=shift; #--产生一个新的Object my $agent = __PACKAGE__->new; #--产生request my $request = HTTP::Request->new(GET => $url); #--取得响应资料 my $response = $agent->request($request); $response->is_success or die "$url: ".$response->message,"/n"; print $response->content; #--改写get_basic_credentials sub get_basic_credentials{ my ($self,$realm,$url) = @_; #--要求使用者输入账号密码 print STDERR "Enter username and password for realm /"$realm/"./n"; print STDERR "username: "; #--取得账号 chomp(my $name=<>); return unless $name; #--取得密码 stty -echo将echo关闭 my $passwd = get_passwd; return($name,$passwd); } 解析HTML与XML：将 HTML档案格式化： HTML::Formatter 是HTML formatters的基本模块。两个家族成员有HTML::FormatText、HTML::FormatPS，两者都无法处理images、forms、tables。格式化HTML的两个步骤 1. 利用HTML::TreeBuilder将HTML file放入一个树状架构中。 2. 利用HTML::Formatter将前面产生的树形图输出至对应的文档或PS档案中。 #!/usr/bin/perl # format_html.pl use strict; use Getopt::Long; use HTML::TreeBuilder; my $PS; #--假如-postscript有设定..则将PS设定为TRUE GetOption('postscript' => /$PS) or die "Usage: format_html.pl [-postscript] [file]/n"; my $formatter; if($PS){ require HTML::FormatPS; $formatter=HTML::FormatPS->new(PaperSize=>'Letter'); }else{ require HTML::FormatText; $formatter = HTML::FormatText->new; } #--建立TreeBuilder对象..然后将@ARGV参数抓进来Parsing #--完毕后呼叫eof关闭tree my $tree = HTML::TreeBuilder->new; $tree->parse($_) while <>; $tree->eof; #--将$tree格式化..并且打印出来 print $formatter->format($tree); $tree->delete; 取得URL第三版本，加入username与password与格式化HTML的内容： #!/usr/bin/perl # get_url3.pl use strict; use LWP; use HTML::FormatText; use HTML::TreeBuilder; use vars '@ISA'; @ISA = 'LWP::UserAgent'; #--取得URL my $url=shift or die "use get_url3 url/n"; #--建立本身的对象 my $agent = __PACKAGE__->new(); #--产生Request Object my $request = HTTP::Request->new(GET => $url); #--建立global variable $html_tree my $html_tree; # will hold the parse tree #--发出request，并将结果送给&process_document subroutine my $response = $agent->request($request,/&process_document); #--检查是否成功 $response->is_success or die "$url: ",$response->message,"/n"; # 将html格式化后打印出来 if($html_tree){ $html_tree->eof; print HTML::FormatText->new->format($html_tree); $html_tree->delete; } #--处理回传结果的subroutine接收三个参数 #--$data,$response,$protocol sub process_document(){ my ($data,$response,$protocol) = @_; if($response->content_type eq "text/html"){ $html_tree ||= HTML::TreeBuilder->new; $html_tree->parse($data); } else { print $data; } } #--替换掉default的username/password查询机制，改成人工输入 sub get_basic_credentials{ my($self,$realm,$uri) = @_; print STDERR "Enter username and password for realm /"$realm/"."; print STDERR "username: "; chomp(my $name=<>); print STDERR "passwd: "; system("stty -echo"); chomp(my $passwd=<>); system("stty echo"); return($name,$passwd); } 利用HTML::Parser将Links取出 #!/usr/bin/perl # print_links.pl use strict; use HTML::Parser; #--建立HTML::Parser Object my $parser=HTML::Parser->new(api_version=>3); #--建立处理start的callback subroutine $parser->handler(start=>/&print_link,'tagname,attr'); #--开始parsing输入的数据 $parser->parse($_) while <>; #--将parser停止 $parser->eof; #--接收两个参数$tagname与$attr两个参数 sub print_link{ my ($tagname,$attr) = @_; #--如果tagname是a的话取出href属性 if($tagname eq 'a' ){ print "link: ",$attr->{href},"/n"; #--如果tabname是img的话取出src属性 }elsif($tagname eq "img"){ print "img: ",$attr->{src},"/n"; } } HTML::Parser API $parser=HTML::Parser->new(@options) 建立HTML::Parser对象，@options最常用的就是api_version=>2 or 3。 $parser->handler($event=>/&handler,$args); 注册HTML::Parser的event handler $event可以有的名称：start、end、text、comment、declaration、process、default。 start 碰到<a> <p> <strong>这类的启始tag时会启动 end 碰到</a></p></strong>这类的tag时会启动 text 在两个<a>与</a>之间的文字 comment 碰到 这类的tag时 declaration 主要应用在XML中 process 主要应用在XML中 default Catchall for anything that is not explicitly handled elsewhere $args是一个用","分隔的字符串可以有的内容如下： tagname Tag名称 text 完整的本文内容 dtext 解碼后的内文 attr 包含属性与数值的reference of hash self HTML::Parser Object 的复制版本 'string' 纯文字 (single or double quotes required!) 支援的method： $parser->handler($event=>/@array,$args) Fill an array with the information that would have been passwd to it, then examine the array at your leisure after the parse is finished. $result=$parser->parse_file($file) $result=$parser->parse($data) $parser->eof 与HTML::TreeBuilder module一样.. $bool= $parser->unbroken_text([$bool]) Default HTML::Parser会将文字分成一个个chunk送至text的handler处理，但是这样可能会造成有些文字被切断了，设定这个function为true，则会将tag中间的文字完整的传送至handler，不会将一段文字中断成两段。 $bool=$parser->xml_mode([$bool]) Xml_mode主要设定是否支持XML文件，如果设定真，可以允需空的element。<tagname />.当碰到这类的tag时，产生start与end的event。开始这个也会使得全部转成小写的机制失效。抓取远程RFC第三版本，加入HTML::Parser这个module： #!/usr/bin/perl #file : search_rfc3.pl use strict; #--设定使用哪些modules use LWP; use HTTP::Request::Common; use HTML::Parser; #--设定目标URL与Reference URL use constant RFC_SEARCH => 'http://www.faqs.org/cgi-bin/rfcsearch'; use constant RFC_REFERER => 'http://www.faqs.org/rfcs/'; #--如果参数小于一个则显示错误 die "Usage: rfc_search2.pl term1 term2.../n" unless @ARGV; #--建立LWP::UserAgent物件 my $ua = $LWP::UserAgent->new; #--设定LWP::UserAgent的ID my $newagent = 'search_rfc/1.0 ('.$ua->agent.')'; $ua->agent($newagent); #--将参数视为搜寻条件 my $search_terms = "@ARGV"; #--建立POST method的Request对象 my $request = POST (RFC_SEARCH, Content => [ query => $search_terms, archive => 'rfcindex' ], Referer => RFC_REFERER ); #--设定HTML::Parser对象的版本 my $parser = HTML::Parser->new(api_version => 3); #--设定HTML::Parser的Trigger $parser->handler(start =>/&start,'self,tagname'); #--设定UserAgent送出request将结果存在$response my $response=$ua->request($request,sub {$parser->parse(shift)}); #--通知$parser结束了 $parser->eof; #--检查是否有成功 die $response->message unless $response->is_success; #--parser callbacks:碰到<START>TAG时使用 #--传入两个参数一个HTML::Parser对象，一个tag名称 sub start{ my ($parser,$tag) = @_; $parser->{last_lag} = $tag; return unless $tag eq "ol"; #--设定HTML::Parser的handler $parser->handler(text =>/&extract,'self,dtext'); $parser->handler(end =>/&end, '$self,name'); } #--碰到</START> TAG时使用 #--传入HTML::Parser对象与Tag名称 sub end{ my ($parser,$tag)= @_; undef $parser->{last_tag}; return unless $tag eq "ol"; #--设定HTML::Parser的handler，失效 $parser->handler(text=>undef); $parser->handler(end=>undef); } #--将本文内容抽取出来 sub extract{ my($parser,$text) = @_; $text=~ s/^/s+//g; $text=~ s//s+$//g; print $text,"/t" if $parser->{last_tag} eq 'a'; print $text,"/n" if $parser->{last_tag} eq 'strong'; }