扶凯

取势 明道 优术

作者为 扶 凯 发表

在 CU 上看帖子,见人问 Perl 整站采集有什么好方案,想了想,使用 Mojo::UserAgent  来实现实在太方便了,花了十分钟就完成了。多年以前看云舒的多线程的 Perl 爬虫那个例子实在很帅,也照着这样写了一个.
就因为云舒和兰花仙子,知道了 Bloom 这样的算法,也知道了 Bloom::Filter 这个模块。我是使用这个来做重复 URL 的检查。Mojo::UserAgent 本身就支持事件,这样就不用多进线。另外本身内置的 DOM::CSS 的这种类,非常给力的。

#!/usr/bin/perl
use strict;
use Mojo::UserAgent;
use Bloom::Filter;
use Smart::Comments;

my $dept_level = 2;
my $baseUrl = Mojo::URL->new($ARGV[0] || 'http://www.chinaunix.net');
my ($domain) = $baseUrl =~ qr#http://(?:www.)?([^/]+)#;
my $filter = Bloom::Filter->new(capacity => 100000, error_rate => 0.0001);
my $ua = Mojo::UserAgent->new(max_redirects => 3);

my $callback;$callback = sub  {
    my ($ua, $tx) = @_;
    return if !$tx->success;

    my $dept = $tx->req->headers->header('dept');
    return if $dept > $dept_level; # 深度
    ++$dept;
    $tx->res->dom->find("a[href]")->each(sub{
            my $attrs  = shift->attr;
            my $newUrl = Mojo::URL->new($attrs->{href});

            # 修复 url 的路径
            if (!$newUrl->host and !$newUrl->scheme) {
                $newUrl->host($tx->req->url->host);
                $newUrl->scheme($tx->req->url->scheme);
            }   
            $newUrl->fragment(undef); # 去掉 foo=bar#23 后面的 #xxx

            # 域名, 协议, 后缀以下不对的都退出
            next if ( $newUrl->scheme ne 'http' && $newUrl->scheme ne 'https' );
            next if $newUrl->host !~ qr/$domain/;
            next if ( $newUrl->path =~ /.(jpg|png|bmp|mp3|wma|wmv|gz|zip|rar|iso|pdf)$/i );

            if( !$filter->check($newUrl) ) {
                print $filter->key_count(), " $dept ", $newUrl, "\n";
                $filter->add($newUrl);
                $ua->get($newUrl => { dept => $dept } => $callback);
            }   
    });
};

$ua->get($baseUrl => { dept => 1} => $callback);
Mojo::IOLoop->start;


使用直接存成文件,然后给上面的 php-oa.com 的域名修改掉,然后 perl ./t11.pl http://www.php-oa.com 这样就行了。
其中 $dept_level 是用来控制抓的深度,24 行的正则是用于控制只抓指定的域名。

兰花仙子的文章地址:使用Bloom Filters

来了就留个评论吧! 9个评论



    nobody 2013年05月29日 的 02:29

    my $callback;$callback = sub {}
    为啥要这样写?

      扶 凯 2013年05月29日 的 09:23

      因为回调中调用了自己。第一次的时候,没有 my 出来时,如果 use strict 时会出错的,提示没有声明。

    Soli 2013年05月31日 的 13:35

    Per真是神奇。

    $end->()
    shift->attrs

    还有这样的用法。

      扶 凯 2013年06月3日 的 06:23

      $end 是匿名函数,匿名函数不加参数的调用就是 $end->().匿名函数就是 my $end = sub {};

    牛氓 2013年06月20日 的 02:35

    把loop换成anyevent

    xiaojian 2013年09月3日 的 09:21

    在执行这个脚本的时候,爬取1000多次后出现如下错误
    Use of uninitialized value in addition (+) at /usr/local/share/perl5/Mojo/Reactor/Poll.pm line 11.
    这个脚本执行成功的环境是32位还是64位,perl的版本呢?

    seufy88 2014年02月13日 的 08:57

    为什么有如下一行代码后
    next if $newUrl->host !~ qr/$domain/;

    执行./t11.pl ‘ http://www.php-oa.com ‘后,仍旧会打印出许多不是php-oa.com一个domain的网址?非常奇怪。按理说,应该只会打印出php-oa.com的域下的网址才是

    seufy88 2014年02月13日 的 09:04

    所以,我认为
    next if $newUrl->host !~ qr/$domain/ 是否真的可以过滤出只有符合 $domain的地址

    yakczh 2014年11月18日 的 14:57

    $callback 里除了ua和tx,怎么传入其他参数?